parent
0333345aa3
commit
13e8da4eea
@ -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:
|
||||
|
@ -98,28 +98,33 @@ class Monad m => VersionedCatalog m (v :: Nat) where
|
||||
getChannels :: 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
|
||||
|
||||
getChannelsV1 :: SafeUser -> AppM (Catalog 1)
|
||||
getChannelsV1 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)
|
||||
|
||||
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 +132,8 @@ handler :: forall v. VersionedCatalog AppM v => ServerT (VersionedAPI v) AppM
|
||||
handler auth = catalogRoot :<|> catalogChannels
|
||||
where
|
||||
catalogChannels :: Channel.ChannelID -> AppM (Catalog v)
|
||||
-- Channel specific catalog returns tags inside the catalog
|
||||
catalogChannels _ = throwM err403{errBody="Not implemented"}
|
||||
catalogRoot :: AppM (Catalog v)
|
||||
-- catalog root returns channels
|
||||
catalogRoot = flip requireLoggedIn auth getChannels
|
||||
|
@ -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"
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user