Merge branch 'sandbox/MasseR/2-opds' of MasseR/ebook-manager into master

Closes #2
This commit is contained in:
Mats Rauhala 2018-08-28 23:28:24 +03:00 committed by Gitea
commit d792cb2a81
8 changed files with 88 additions and 34 deletions

View File

@ -1,6 +1,3 @@
-- Initial ebook-manager.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: ebook-manager name: ebook-manager
version: 0.1.0.0 version: 0.1.0.0
-- synopsis: -- synopsis:

View File

@ -27,8 +27,8 @@ data Index = Index
type API = Get '[HTML] (AppView Index) type API = Get '[HTML] (AppView Index)
:<|> Users.API :<|> Users.API
:<|> "api" :> Channels.API :<|> "api" :> "current" :> Channels.API
:<|> "api" :> Books.API :<|> "api" :> "current" :> Books.API
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1 :<|> "api" :> "1" :> Catalogue.VersionedAPI 1
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1 :<|> "api" :> "current" :> Catalogue.VersionedAPI 1

View File

@ -36,14 +36,14 @@ import Crypto.Hash (digestFromByteString)
data JsonBook = JsonBook { identifier :: BookID data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text , contentType :: Text
, title :: Maybe Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, channels :: [Text] , channels :: [Text]
, tags :: [Text] } , tags :: [Text] }
deriving (Generic, Show) deriving (Generic, Show)
data PostBook = PostBook { contentType :: Text data PostBook = PostBook { contentType :: Text
, title :: Maybe Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, channels :: [Text] , channels :: [Text]
, tags :: [Text] } , tags :: [Text] }
@ -61,7 +61,9 @@ type BaseAPI = "books" :> Get '[JSON] [JsonBook]
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook :<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent :<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent
:<|> "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString :<|> GetBook
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
handler :: ServerT API AppM handler :: ServerT API AppM
handler user = listBooksHandler user handler user = listBooksHandler user

View File

@ -17,14 +17,16 @@
module API.Catalogue (VersionedAPI, handler) where module API.Catalogue (VersionedAPI, handler) where
import Types import Types
import Servant import Servant hiding (contentType)
import ClassyPrelude import ClassyPrelude
import GHC.TypeLits import GHC.TypeLits
import Server.Auth import Server.Auth
import Servant.Auth as SA import Servant.Auth as SA
import Servant.XML import Servant.XML
import qualified Database.Channel as Channel import qualified Database.Channel as Channel
import Database.Book (Book(..))
import Database import Database
import qualified API.Books
-- This is my first try on going to versioned apis, things might change -- This is my first try on going to versioned apis, things might change
-- I think my rule of thumb is that you can add new things as you want, but -- I think my rule of thumb is that you can add new things as you want, but
@ -96,30 +98,57 @@ instance ToNode (Catalog 1) where
class Monad m => VersionedCatalog m (v :: Nat) where class Monad m => VersionedCatalog m (v :: Nat) where
getChannels :: SafeUser -> m (Catalog v) getChannels :: SafeUser -> m (Catalog v)
getBooks :: Channel.ChannelID -> SafeUser -> m (Catalog v)
instance VersionedCatalog AppM 1 where instance VersionedCatalog AppM 1 where
getChannels SafeUser{username} = do getChannels = getChannelsV1
updated <- liftIO getCurrentTime getBooks = getBooksV1
let self = Rel ("/api/current/" <> selfUrl)
-- I'm not sure if this safe link approach is really useable with this relUrl :: Link -> Rel
-- api hierarchy since I can't access the topmost api from here. Also relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
-- authentication would bring a little bit of extra effort as well
selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1)) getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
start = self getBooksV1 channelID SafeUser{username} = do
pagination = Pagination Nothing Nothing updated <- liftIO getCurrentTime
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username) let self = relUrl selfUrl
pure CatalogV1{..} start = relUrl startUrl
where selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
fromChannel :: UTCTime -> Channel.Channel -> Entry 1 startUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
fromChannel updated Channel.Channel{..} = pagination = Pagination Nothing Nothing
let url = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier entries <- map (toEntry updated) <$> runDB (Channel.channelBooks username channelID)
self = Rel ("/api/current/" <> url) pure CatalogV1{..}
in EntryV1 channel channel updated channel (Left $ SubSection self) where
toEntry updated Book{description,title,identifier=bookId} =
let content = fromMaybe "no content" description
identifier = pack . show $ bookId
link = Right (Acquisition (relUrl (safeLink (Proxy @API.Books.BaseAPI) (Proxy @API.Books.GetBook) bookId)))
in EntryV1{..}
getChannelsV1 :: SafeUser -> AppM (Catalog 1)
getChannelsV1 SafeUser{username} = do
updated <- liftIO getCurrentTime
let self = relUrl selfUrl
-- I'm not sure if this safe link approach is really useable with this
-- api hierarchy since I can't access the topmost api from here. Also
-- authentication would bring a little bit of extra effort as well
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
start = self
pagination = Pagination Nothing Nothing
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
pure CatalogV1{..}
where
fromChannel :: UTCTime -> Channel.Channel -> Entry 1
fromChannel updated Channel.Channel{..} =
let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
self = relUrl url
in EntryV1 channel channel updated channel (Left $ SubSection self)
type VersionedAPI (v :: Nat) = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI v type VersionedAPI (v :: Nat) = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI v
type RootCatalog (v :: Nat) = "catalog" :> Get '[XML] (Catalog v) type CatalogContent = '[XML, OPDS]
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get '[XML] (Catalog v)
type RootCatalog (v :: Nat) = "catalog" :> Get CatalogContent (Catalog v)
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get CatalogContent (Catalog v)
type BaseAPI (v :: Nat) = RootCatalog v type BaseAPI (v :: Nat) = RootCatalog v
:<|> ChannelCatalog v :<|> ChannelCatalog v
@ -127,6 +156,8 @@ handler :: forall v. VersionedCatalog AppM v => ServerT (VersionedAPI v) AppM
handler auth = catalogRoot :<|> catalogChannels handler auth = catalogRoot :<|> catalogChannels
where where
catalogChannels :: Channel.ChannelID -> AppM (Catalog v) catalogChannels :: Channel.ChannelID -> AppM (Catalog v)
catalogChannels _ = throwM err403{errBody="Not implemented"} -- Channel specific catalog returns tags inside the catalog
catalogChannels identifier = flip requireLoggedIn auth (getBooks identifier)
catalogRoot :: AppM (Catalog v) catalogRoot :: AppM (Catalog v)
-- catalog root returns channels
catalogRoot = flip requireLoggedIn auth getChannels catalogRoot = flip requireLoggedIn auth getChannels

View File

@ -51,7 +51,7 @@ getBook identifier owner = listToMaybe . fromRels <$> query q
return book return book
data InsertBook = InsertBook { contentType :: Text data InsertBook = InsertBook { contentType :: Text
, title :: Maybe Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, owner :: Username } , owner :: Username }
@ -68,7 +68,7 @@ insertBook InsertBook{..} = do
data UpdateBook = UpdateBook { identifier :: BookID data UpdateBook = UpdateBook { identifier :: BookID
, contentType :: Text , contentType :: Text
, title :: Maybe Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, owner :: Username , owner :: Username
, tags :: [Text] , tags :: [Text]

View File

@ -11,8 +11,9 @@ module Database.Channel
, Visibility(..) , Visibility(..)
, clearChannels , clearChannels
, booksChannels , booksChannels
, channelBooks
, Channel(..) , Channel(..)
, ChannelID ) , ChannelID(..) )
where where
import ClassyPrelude import ClassyPrelude
@ -80,6 +81,19 @@ insertChannel username channel visibility = runMaybeT $ do
restrict (user .== literal username) restrict (user .== literal username)
return userId return userId
channelBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> ChannelID -> m [Book]
channelBooks username identifier = fromRels <$> query q
where
q = do
channelId :*: bookId' <- select (gen bookChannels)
channelId' :*: _ :*: owner :*: _ <- select (gen channels)
userId :*: _ :*: username' :*: _ <- select (gen users)
book@(bookId :*: _) <- select (gen books)
restrict (username' .== literal username .&& owner .== userId)
restrict (channelId .== literal identifier .&& channelId .== channelId')
restrict (bookId .== bookId')
return book
booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel] booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel]
booksChannels bookId = fromRels <$> query q booksChannels bookId = fromRels <$> query q
where where

View File

@ -42,7 +42,7 @@ instance SqlType Username where
newtype UserID = UserID {unUserID :: Int} deriving (Show) newtype UserID = UserID {unUserID :: Int} deriving (Show)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord) newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON) newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON)
@ -101,7 +101,7 @@ newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
data Book = Book { identifier :: BookID data Book = Book { identifier :: BookID
, contentHash :: Maybe HashDigest , contentHash :: Maybe HashDigest
, contentType :: Text , contentType :: Text
, title :: Maybe Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, owner :: UserID } , owner :: UserID }
deriving (Show, Generic) deriving (Show, Generic)

View File

@ -1,9 +1,11 @@
{-# Language OverloadedStrings #-} {-# Language OverloadedStrings #-}
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
{-# Language MultiParamTypeClasses #-} {-# Language MultiParamTypeClasses #-}
{-# Language TypeApplications #-}
module Servant.XML module Servant.XML
( ToNode(..) ( ToNode(..)
, XML , XML
, OPDS
, Text.Hamlet.XML.xml , Text.Hamlet.XML.xml
, iso8601 ) , iso8601 )
where where
@ -16,14 +18,22 @@ import Network.HTTP.Media.MediaType
data XML data XML
data OPDS
instance (ToNode a) => MimeRender XML a where instance (ToNode a) => MimeRender XML a where
mimeRender _ a = mimeRender _ a =
let [NodeElement root] = toNode a let [NodeElement root] = toNode a
in renderLBS def (Document (Prologue [] Nothing []) root []) in renderLBS def (Document (Prologue [] Nothing []) root [])
instance (ToNode a) => MimeRender OPDS a where
mimeRender _ a = mimeRender (Proxy @XML) a
instance Accept XML where instance Accept XML where
contentType _ = "application" // "xml" /: ("charset", "utf-8") contentType _ = "application" // "xml" /: ("charset", "utf-8")
instance Accept OPDS where
contentType _ = "application" // "atom+xml" /: ("charset", "utf-8") /: ("profile", "opds-catalog")
iso8601 :: UTCTime -> Text iso8601 :: UTCTime -> Text
iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"