Compare commits

...

1 Commits

Author SHA1 Message Date
13e8da4eea WIP
- Relates to #2
2018-08-14 22:12:43 +03:00
3 changed files with 36 additions and 22 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

@ -98,28 +98,33 @@ class Monad m => VersionedCatalog m (v :: Nat) where
getChannels :: SafeUser -> m (Catalog v) getChannels :: SafeUser -> m (Catalog v)
instance VersionedCatalog AppM 1 where instance VersionedCatalog AppM 1 where
getChannels SafeUser{username} = do getChannels = getChannelsV1
updated <- liftIO getCurrentTime
let self = Rel ("/api/current/" <> selfUrl) getChannelsV1 :: SafeUser -> AppM (Catalog 1)
-- I'm not sure if this safe link approach is really useable with this getChannelsV1 SafeUser{username} = do
-- api hierarchy since I can't access the topmost api from here. Also updated <- liftIO getCurrentTime
-- authentication would bring a little bit of extra effort as well let self = Rel ("/api/current/" <> selfUrl)
selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1)) -- I'm not sure if this safe link approach is really useable with this
start = self -- api hierarchy since I can't access the topmost api from here. Also
pagination = Pagination Nothing Nothing -- authentication would bring a little bit of extra effort as well
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username) selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
pure CatalogV1{..} start = self
where pagination = Pagination Nothing Nothing
fromChannel :: UTCTime -> Channel.Channel -> Entry 1 entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
fromChannel updated Channel.Channel{..} = pure CatalogV1{..}
let url = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier where
self = Rel ("/api/current/" <> url) fromChannel :: UTCTime -> Channel.Channel -> Entry 1
in EntryV1 channel channel updated channel (Left $ SubSection self) 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)
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 +132,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)
-- Channel specific catalog returns tags inside the catalog
catalogChannels _ = throwM err403{errBody="Not implemented"} catalogChannels _ = throwM err403{errBody="Not implemented"}
catalogRoot :: AppM (Catalog v) catalogRoot :: AppM (Catalog v)
-- catalog root returns channels
catalogRoot = flip requireLoggedIn auth getChannels catalogRoot = flip requireLoggedIn auth getChannels

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"