Start working on the (versioned) OPDS catalog
This commit is contained in:
parent
1a8646df46
commit
0333345aa3
@ -20,15 +20,18 @@ executable ebook-manager
|
|||||||
other-modules: Devel.Main
|
other-modules: Devel.Main
|
||||||
, API
|
, API
|
||||||
, API.Books
|
, API.Books
|
||||||
|
, API.Catalogue
|
||||||
, API.Channels
|
, API.Channels
|
||||||
, API.Users
|
, API.Users
|
||||||
, Configuration
|
, Configuration
|
||||||
|
, Data.Versioned
|
||||||
, Database
|
, Database
|
||||||
, Database.Book
|
, Database.Book
|
||||||
, Database.Channel
|
, Database.Channel
|
||||||
, Database.Schema
|
, Database.Schema
|
||||||
, Database.User
|
, Database.User
|
||||||
, Datastore
|
, Datastore
|
||||||
|
, Servant.XML
|
||||||
, Server
|
, Server
|
||||||
, Server.Auth
|
, Server.Auth
|
||||||
, Types
|
, Types
|
||||||
@ -46,6 +49,7 @@ executable ebook-manager
|
|||||||
, foreign-store
|
, foreign-store
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, http-api-data
|
, http-api-data
|
||||||
|
, http-media
|
||||||
, jose
|
, jose
|
||||||
, lens
|
, lens
|
||||||
, lucid
|
, lucid
|
||||||
@ -72,6 +76,8 @@ executable ebook-manager
|
|||||||
, warp
|
, warp
|
||||||
, x509
|
, x509
|
||||||
, x509-store
|
, x509-store
|
||||||
|
, xml-conduit
|
||||||
|
, xml-hamlet
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
default-extensions: DeriveGeneric
|
default-extensions: DeriveGeneric
|
||||||
, NoImplicitPrelude
|
, NoImplicitPrelude
|
||||||
|
@ -21,19 +21,24 @@ import View
|
|||||||
import qualified API.Users as Users
|
import qualified API.Users as Users
|
||||||
import qualified API.Channels as Channels
|
import qualified API.Channels as Channels
|
||||||
import qualified API.Books as Books
|
import qualified API.Books as Books
|
||||||
|
import qualified API.Catalogue as Catalogue
|
||||||
|
|
||||||
data Index = Index
|
data Index = Index
|
||||||
|
|
||||||
type API = Get '[HTML] (AppView Index)
|
type API = Get '[HTML] (AppView Index)
|
||||||
:<|> Users.API
|
:<|> Users.API
|
||||||
:<|> Channels.API
|
:<|> "api" :> Channels.API
|
||||||
:<|> Books.API
|
:<|> "api" :> Books.API
|
||||||
|
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1
|
||||||
|
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1
|
||||||
|
|
||||||
handler :: ServerT API AppM
|
handler :: ServerT API AppM
|
||||||
handler = indexHandler
|
handler = indexHandler
|
||||||
:<|> Users.handler
|
:<|> Users.handler
|
||||||
:<|> Channels.handler
|
:<|> Channels.handler
|
||||||
:<|> Books.handler
|
:<|> Books.handler
|
||||||
|
:<|> Catalogue.handler
|
||||||
|
:<|> Catalogue.handler
|
||||||
|
|
||||||
instance ToHtml Index where
|
instance ToHtml Index where
|
||||||
toHtml _ = do
|
toHtml _ = do
|
||||||
|
132
src/API/Catalogue.hs
Normal file
132
src/API/Catalogue.hs
Normal file
@ -0,0 +1,132 @@
|
|||||||
|
{-# Language DataKinds #-}
|
||||||
|
{-# Language NamedFieldPuns #-}
|
||||||
|
{-# Language TypeApplications #-}
|
||||||
|
{-# Language KindSignatures #-}
|
||||||
|
{-# Language TypeFamilies #-}
|
||||||
|
{-# Language GeneralizedNewtypeDeriving #-}
|
||||||
|
{-# Language DuplicateRecordFields #-}
|
||||||
|
{-# Language TypeOperators #-}
|
||||||
|
{-# Language StandaloneDeriving #-}
|
||||||
|
{-# Language DeriveGeneric #-}
|
||||||
|
{-# Language FlexibleInstances #-}
|
||||||
|
{-# Language FlexibleContexts #-}
|
||||||
|
{-# Language QuasiQuotes #-}
|
||||||
|
{-# Language TemplateHaskell #-}
|
||||||
|
{-# Language MultiParamTypeClasses #-}
|
||||||
|
{-# Language ScopedTypeVariables #-}
|
||||||
|
module API.Catalogue (VersionedAPI, handler) where
|
||||||
|
|
||||||
|
import Types
|
||||||
|
import Servant
|
||||||
|
import ClassyPrelude
|
||||||
|
import GHC.TypeLits
|
||||||
|
import Server.Auth
|
||||||
|
import Servant.Auth as SA
|
||||||
|
import Servant.XML
|
||||||
|
import qualified Database.Channel as Channel
|
||||||
|
import Database
|
||||||
|
|
||||||
|
-- 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
|
||||||
|
-- deleting and modifying warrants a new version
|
||||||
|
|
||||||
|
data family Catalog :: Nat -> *
|
||||||
|
|
||||||
|
data family Entry :: Nat -> *
|
||||||
|
|
||||||
|
newtype Rel = Rel { unRel :: Text } deriving (IsString, Show)
|
||||||
|
|
||||||
|
data Pagination = Pagination { previous :: Maybe Rel
|
||||||
|
, next :: Maybe Rel }
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
newtype SubSection = SubSection Rel deriving (Show)
|
||||||
|
newtype Acquisition = Acquisition Rel deriving (Show)
|
||||||
|
|
||||||
|
data instance Entry 1 = EntryV1 { title :: Text
|
||||||
|
, identifier :: Text
|
||||||
|
, updated :: UTCTime
|
||||||
|
, content :: Text
|
||||||
|
, link :: Either SubSection Acquisition
|
||||||
|
}
|
||||||
|
|
||||||
|
data instance Catalog 1 = CatalogV1 { updated :: UTCTime
|
||||||
|
, self :: Rel
|
||||||
|
, start :: Rel
|
||||||
|
, pagination :: Pagination
|
||||||
|
, entries :: [Entry 1]
|
||||||
|
}
|
||||||
|
|
||||||
|
deriving instance Show (Catalog 1)
|
||||||
|
deriving instance Show (Entry 1)
|
||||||
|
deriving instance Generic (Catalog 1)
|
||||||
|
deriving instance Generic (Entry 1)
|
||||||
|
|
||||||
|
instance ToNode SubSection where
|
||||||
|
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]
|
||||||
|
|
||||||
|
instance ToNode Acquisition where
|
||||||
|
toNode (Acquisition rel) = [xml|<link type="application/epub+zip" rel="http://opds-spec.org/acquisition" href="#{unRel rel}">|]
|
||||||
|
|
||||||
|
instance ToNode (Entry 1) where
|
||||||
|
toNode EntryV1{..} = [xml|
|
||||||
|
<entry>
|
||||||
|
<title>#{title}
|
||||||
|
<id>#{identifier}
|
||||||
|
<updated>#{iso8601 updated}
|
||||||
|
<content>#{content}
|
||||||
|
^{either toNode toNode link}
|
||||||
|
|]
|
||||||
|
|
||||||
|
instance ToNode (Catalog 1) where
|
||||||
|
toNode CatalogV1{..} = [xml|
|
||||||
|
<feed xmlns="http://www.w3.org/2005/Atom" xmlns:opds="http://opds-spec.org/2010/catalog">
|
||||||
|
<id>#{unRel self}
|
||||||
|
<title>Give me a title
|
||||||
|
<updated>#{iso8601 updated}
|
||||||
|
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="self" href="#{unRel self}">
|
||||||
|
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="start" href="#{unRel start}">
|
||||||
|
$maybe n <- (next pagination)
|
||||||
|
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="next" href="#{unRel n}">
|
||||||
|
$maybe p <- (previous pagination)
|
||||||
|
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="previous" href="#{unRel p}">
|
||||||
|
|
||||||
|
^{toNode entries}
|
||||||
|
|]
|
||||||
|
|
||||||
|
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)
|
||||||
|
|
||||||
|
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 BaseAPI (v :: Nat) = RootCatalog v
|
||||||
|
:<|> ChannelCatalog v
|
||||||
|
|
||||||
|
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"}
|
||||||
|
catalogRoot :: AppM (Catalog v)
|
||||||
|
catalogRoot = flip requireLoggedIn auth getChannels
|
24
src/Data/Versioned.hs
Normal file
24
src/Data/Versioned.hs
Normal file
@ -0,0 +1,24 @@
|
|||||||
|
{-# Language KindSignatures #-}
|
||||||
|
{-# Language DataKinds #-}
|
||||||
|
{-# Language DefaultSignatures #-}
|
||||||
|
{-# Language MultiParamTypeClasses #-}
|
||||||
|
{-# Language FunctionalDependencies #-}
|
||||||
|
module Data.Versioned where
|
||||||
|
|
||||||
|
import GHC.TypeLits
|
||||||
|
import ClassyPrelude
|
||||||
|
import Data.Generics.Product
|
||||||
|
|
||||||
|
newtype Versioned (v :: Nat) a = Versioned a deriving (Show)
|
||||||
|
|
||||||
|
instance Functor (Versioned v) where
|
||||||
|
fmap f (Versioned a) = Versioned (f a)
|
||||||
|
|
||||||
|
instance Applicative (Versioned v) where
|
||||||
|
pure = Versioned
|
||||||
|
(Versioned f) <*> (Versioned a) = Versioned (f a)
|
||||||
|
|
||||||
|
class Migrate a b | b -> a where
|
||||||
|
migrate :: a -> b
|
||||||
|
default migrate :: (Subtype b a) => a -> b
|
||||||
|
migrate = upcast
|
@ -4,7 +4,8 @@ module Database.Channel
|
|||||||
( userChannels
|
( userChannels
|
||||||
, insertChannel
|
, insertChannel
|
||||||
, booksChannels
|
, booksChannels
|
||||||
, Channel(..) )
|
, Channel(..)
|
||||||
|
, ChannelID )
|
||||||
where
|
where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
@ -44,7 +44,7 @@ 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)
|
||||||
|
|
||||||
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show)
|
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData)
|
||||||
|
|
||||||
newtype TagID = TagID {unTagID :: Int} deriving (Show)
|
newtype TagID = TagID {unTagID :: Int} deriving (Show)
|
||||||
|
|
||||||
|
34
src/Servant/XML.hs
Normal file
34
src/Servant/XML.hs
Normal file
@ -0,0 +1,34 @@
|
|||||||
|
{-# Language OverloadedStrings #-}
|
||||||
|
{-# Language FlexibleInstances #-}
|
||||||
|
{-# Language MultiParamTypeClasses #-}
|
||||||
|
module Servant.XML
|
||||||
|
( ToNode(..)
|
||||||
|
, XML
|
||||||
|
, Text.Hamlet.XML.xml
|
||||||
|
, iso8601 )
|
||||||
|
where
|
||||||
|
|
||||||
|
import Text.XML
|
||||||
|
import ClassyPrelude
|
||||||
|
import Text.Hamlet.XML
|
||||||
|
import Servant
|
||||||
|
import Network.HTTP.Media.MediaType
|
||||||
|
|
||||||
|
data XML
|
||||||
|
|
||||||
|
instance (ToNode a) => MimeRender XML a where
|
||||||
|
mimeRender _ a =
|
||||||
|
let [NodeElement root] = toNode a
|
||||||
|
in renderLBS def (Document (Prologue [] Nothing []) root [])
|
||||||
|
|
||||||
|
instance Accept XML where
|
||||||
|
contentType _ = "application" // "xml" /: ("charset", "utf-8")
|
||||||
|
|
||||||
|
iso8601 :: UTCTime -> Text
|
||||||
|
iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
|
||||||
|
|
||||||
|
class ToNode a where
|
||||||
|
toNode :: a -> [Node]
|
||||||
|
|
||||||
|
instance (ToNode a) => ToNode [a] where
|
||||||
|
toNode = concatMap toNode
|
Loading…
Reference in New Issue
Block a user