From 0333345aa30b1668047140c7ed7a3032c43d8681 Mon Sep 17 00:00:00 2001 From: Mats Rauhala Date: Tue, 14 Aug 2018 00:03:52 +0300 Subject: [PATCH] Start working on the (versioned) OPDS catalog --- ebook-manager.cabal | 6 ++ src/API.hs | 9 ++- src/API/Catalogue.hs | 132 ++++++++++++++++++++++++++++++++++++++++ src/Data/Versioned.hs | 24 ++++++++ src/Database/Channel.hs | 3 +- src/Database/Schema.hs | 2 +- src/Servant/XML.hs | 34 +++++++++++ 7 files changed, 206 insertions(+), 4 deletions(-) create mode 100644 src/API/Catalogue.hs create mode 100644 src/Data/Versioned.hs create mode 100644 src/Servant/XML.hs diff --git a/ebook-manager.cabal b/ebook-manager.cabal index 7731da8..b574f6a 100644 --- a/ebook-manager.cabal +++ b/ebook-manager.cabal @@ -20,15 +20,18 @@ executable ebook-manager other-modules: Devel.Main , API , API.Books + , API.Catalogue , API.Channels , API.Users , Configuration + , Data.Versioned , Database , Database.Book , Database.Channel , Database.Schema , Database.User , Datastore + , Servant.XML , Server , Server.Auth , Types @@ -46,6 +49,7 @@ executable ebook-manager , foreign-store , generic-lens , http-api-data + , http-media , jose , lens , lucid @@ -72,6 +76,8 @@ executable ebook-manager , warp , x509 , x509-store + , xml-conduit + , xml-hamlet hs-source-dirs: src default-extensions: DeriveGeneric , NoImplicitPrelude diff --git a/src/API.hs b/src/API.hs index e1bdc83..b1ef02c 100644 --- a/src/API.hs +++ b/src/API.hs @@ -21,19 +21,24 @@ import View import qualified API.Users as Users import qualified API.Channels as Channels import qualified API.Books as Books +import qualified API.Catalogue as Catalogue data Index = Index type API = Get '[HTML] (AppView Index) :<|> Users.API - :<|> Channels.API - :<|> Books.API + :<|> "api" :> Channels.API + :<|> "api" :> Books.API + :<|> "api" :> "1" :> Catalogue.VersionedAPI 1 + :<|> "api" :> "current" :> Catalogue.VersionedAPI 1 handler :: ServerT API AppM handler = indexHandler :<|> Users.handler :<|> Channels.handler :<|> Books.handler + :<|> Catalogue.handler + :<|> Catalogue.handler instance ToHtml Index where toHtml _ = do diff --git a/src/API/Catalogue.hs b/src/API/Catalogue.hs new file mode 100644 index 0000000..de125dc --- /dev/null +++ b/src/API/Catalogue.hs @@ -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||] + +instance ToNode Acquisition where + toNode (Acquisition rel) = [xml||] + +instance ToNode (Entry 1) where + toNode EntryV1{..} = [xml| + + #{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 diff --git a/src/Data/Versioned.hs b/src/Data/Versioned.hs new file mode 100644 index 0000000..a929842 --- /dev/null +++ b/src/Data/Versioned.hs @@ -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 diff --git a/src/Database/Channel.hs b/src/Database/Channel.hs index 6e0b604..3b85fe2 100644 --- a/src/Database/Channel.hs +++ b/src/Database/Channel.hs @@ -4,7 +4,8 @@ module Database.Channel ( userChannels , insertChannel , booksChannels - , Channel(..) ) + , Channel(..) + , ChannelID ) where import ClassyPrelude diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs index 24d50a9..88b5ef2 100644 --- a/src/Database/Schema.hs +++ b/src/Database/Schema.hs @@ -44,7 +44,7 @@ newtype UserID = UserID {unUserID :: Int} deriving (Show) 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) diff --git a/src/Servant/XML.hs b/src/Servant/XML.hs new file mode 100644 index 0000000..42a2fca --- /dev/null +++ b/src/Servant/XML.hs @@ -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