From cd086165dbd6f9c03849aa8ed2a56e4619b5b4e7 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 14 Aug 2018 22:11:52 +0300 Subject: [PATCH] Initial OPDS support Channel listing (#2) List books (#2) Closes (#2) --- ebook-manager.cabal | 3 -- src/API.hs | 4 +-- src/API/Books.hs | 8 +++-- src/API/Catalogue.hs | 73 +++++++++++++++++++++++++++++------------ src/Database/Book.hs | 4 +-- src/Database/Channel.hs | 16 ++++++++- src/Database/Schema.hs | 4 +-- src/Servant/XML.hs | 10 ++++++ 8 files changed, 88 insertions(+), 34 deletions(-) diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 2d699d6..4d262ee 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -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 version: 0.1.0.0 -- synopsis: diff --git a/src/API.hs b/src/API.hs index b1ef02c..3186b6a 100644 --- a/src/API.hs +++ b/src/API.hs @@ -27,8 +27,8 @@ data Index = Index type API = Get '[HTML] (AppView Index) :<|> Users.API - :<|> "api" :> Channels.API - :<|> "api" :> Books.API + :<|> "api" :> "current" :> Channels.API + :<|> "api" :> "current" :> Books.API :<|> "api" :> "1" :> Catalogue.VersionedAPI 1 :<|> "api" :> "current" :> Catalogue.VersionedAPI 1 diff --git a/src/API/Books.hs b/src/API/Books.hs index 3cb0369..6a9ebdb 100644 --- a/src/API/Books.hs +++ b/src/API/Books.hs @@ -36,14 +36,14 @@ import Crypto.Hash (digestFromByteString) data JsonBook = JsonBook { identifier :: BookID , contentType :: Text - , title :: Maybe Text + , title :: Text , description :: Maybe Text , channels :: [Text] , tags :: [Text] } deriving (Generic, Show) data PostBook = PostBook { contentType :: Text - , title :: Maybe Text + , title :: Text , description :: Maybe Text , channels :: [Text] , tags :: [Text] } @@ -61,7 +61,9 @@ type BaseAPI = "books" :> Get '[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 :> 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 user = listBooksHandler user diff --git a/src/API/Catalogue.hs b/src/API/Catalogue.hs index de125dc..9a36699 100644 --- a/src/API/Catalogue.hs +++ b/src/API/Catalogue.hs @@ -17,14 +17,16 @@ module API.Catalogue (VersionedAPI, handler) where import Types -import Servant +import Servant hiding (contentType) import ClassyPrelude import GHC.TypeLits import Server.Auth import Servant.Auth as SA import Servant.XML import qualified Database.Channel as Channel +import Database.Book (Book(..)) import Database +import qualified API.Books -- 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 @@ -96,30 +98,57 @@ instance ToNode (Catalog 1) where class Monad m => VersionedCatalog m (v :: Nat) where getChannels :: SafeUser -> m (Catalog v) + getBooks :: Channel.ChannelID -> SafeUser -> m (Catalog v) instance VersionedCatalog AppM 1 where - getChannels SafeUser{username} = do - updated <- liftIO getCurrentTime - let self = Rel ("/api/current/" <> 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 = pack . uriPath . linkURI $ 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 = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier - self = Rel ("/api/current/" <> url) - in EntryV1 channel channel updated channel (Left $ SubSection self) + getChannels = getChannelsV1 + getBooks = getBooksV1 + +relUrl :: Link -> Rel +relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x)) + +getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1) +getBooksV1 channelID SafeUser{username} = do + updated <- liftIO getCurrentTime + let self = relUrl selfUrl + start = relUrl startUrl + selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID + startUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1)) + pagination = Pagination Nothing Nothing + entries <- map (toEntry updated) <$> runDB (Channel.channelBooks username channelID) + pure CatalogV1{..} + 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 RootCatalog (v :: Nat) = "catalog" :> Get '[XML] (Catalog v) -type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get '[XML] (Catalog v) +type CatalogContent = '[XML, OPDS] + +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 :<|> ChannelCatalog v @@ -127,6 +156,8 @@ handler :: forall v. VersionedCatalog AppM v => ServerT (VersionedAPI v) AppM handler auth = catalogRoot :<|> catalogChannels where 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) + -- catalog root returns channels catalogRoot = flip requireLoggedIn auth getChannels diff --git a/src/Database/Book.hs b/src/Database/Book.hs index eb78b9d..8ce492c 100644 --- a/src/Database/Book.hs +++ b/src/Database/Book.hs @@ -51,7 +51,7 @@ getBook identifier owner = listToMaybe . fromRels <$> query q return book data InsertBook = InsertBook { contentType :: Text - , title :: Maybe Text + , title :: Text , description :: Maybe Text , owner :: Username } @@ -68,7 +68,7 @@ insertBook InsertBook{..} = do data UpdateBook = UpdateBook { identifier :: BookID , contentType :: Text - , title :: Maybe Text + , title :: Text , description :: Maybe Text , owner :: Username , tags :: [Text] diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 4ef3627..ef0515a 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -11,8 +11,9 @@ module Database.Channel , Visibility(..) , clearChannels , booksChannels + , channelBooks , Channel(..) - , ChannelID ) + , ChannelID(..) ) where import ClassyPrelude @@ -80,6 +81,19 @@ insertChannel username channel visibility = runMaybeT $ do restrict (user .== literal username) 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 bookId = fromRels <$> query q where diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 8084168..598abdb 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -42,7 +42,7 @@ instance SqlType Username where 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) @@ -101,7 +101,7 @@ newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show data Book = Book { identifier :: BookID , contentHash :: Maybe HashDigest , contentType :: Text - , title :: Maybe Text + , title :: Text , description :: Maybe Text , owner :: UserID } deriving (Show, Generic) diff --git a/src/Servant/XML.hs b/src/Servant/XML.hs index 42a2fca..cbc2c7b 100644 --- a/src/Servant/XML.hs +++ b/src/Servant/XML.hs @@ -1,9 +1,11 @@ {-# Language OverloadedStrings #-} {-# Language FlexibleInstances #-} {-# Language MultiParamTypeClasses #-} +{-# Language TypeApplications #-} module Servant.XML ( ToNode(..) , XML + , OPDS , Text.Hamlet.XML.xml , iso8601 ) where @@ -16,14 +18,22 @@ import Network.HTTP.Media.MediaType data XML +data OPDS + instance (ToNode a) => MimeRender XML a where mimeRender _ a = let [NodeElement root] = toNode a in renderLBS def (Document (Prologue [] Nothing []) root []) +instance (ToNode a) => MimeRender OPDS a where + mimeRender _ a = mimeRender (Proxy @XML) a + instance Accept XML where contentType _ = "application" // "xml" /: ("charset", "utf-8") +instance Accept OPDS where + contentType _ = "application" // "atom+xml" /: ("charset", "utf-8") /: ("profile", "opds-catalog") + iso8601 :: UTCTime -> Text iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" -- 2.47.0