Start working on the (versioned) OPDS catalog

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

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

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|<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

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

src/Database/Channel.hs

@@ -4,7 +4,8 @@ module Database.Channel
   ( userChannels
   , insertChannel
   , booksChannels
-  , Channel(..) )
+  , Channel(..)
+  , ChannelID )
   where
 
 import ClassyPrelude

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)
 

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