parent
0037d4691e
commit
cd086165db
@ -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:
|
||||||
|
@ -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
|
||||||
|
|
||||||
|
@ -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
|
||||||
|
@ -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,15 +98,40 @@ 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
|
||||||
|
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
|
updated <- liftIO getCurrentTime
|
||||||
let self = Rel ("/api/current/" <> selfUrl)
|
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
|
-- 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
|
-- api hierarchy since I can't access the topmost api from here. Also
|
||||||
-- authentication would bring a little bit of extra effort as well
|
-- authentication would bring a little bit of extra effort as well
|
||||||
selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
|
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
|
||||||
start = self
|
start = self
|
||||||
pagination = Pagination Nothing Nothing
|
pagination = Pagination Nothing Nothing
|
||||||
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
|
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
|
||||||
@ -112,14 +139,16 @@ instance VersionedCatalog AppM 1 where
|
|||||||
where
|
where
|
||||||
fromChannel :: UTCTime -> Channel.Channel -> Entry 1
|
fromChannel :: UTCTime -> Channel.Channel -> Entry 1
|
||||||
fromChannel updated Channel.Channel{..} =
|
fromChannel updated Channel.Channel{..} =
|
||||||
let url = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
|
let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
|
||||||
self = Rel ("/api/current/" <> url)
|
self = relUrl url
|
||||||
in EntryV1 channel channel updated channel (Left $ SubSection self)
|
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
|
||||||
|
@ -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]
|
||||||
|
@ -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
|
||||||
|
@ -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)
|
||||||
|
@ -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"
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user