MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

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

Browse Source 
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
ebook-manager.cabal
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
version: 0.1.0.0
-- synopsis:

4
src/API.hs
View File

@ -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

8
src/API/Books.hs
View File

@ -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

73
src/API/Catalogue.hs
View File

@ -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

4
src/Database/Book.hs
View File

@ -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]

16
src/Database/Channel.hs
View File

@ -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

4
src/Database/Schema.hs
View File

@ -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)

10
src/Servant/XML.hs
View File

@ -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"