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}
+ #{identifier}
+ #{iso8601 updated}
+ #{content}
+ ^{either toNode toNode link}
+ |]
+
+instance ToNode (Catalog 1) where
+ toNode CatalogV1{..} = [xml|
+
+ #{unRel self}
+ Give me a title
+ #{iso8601 updated}
+
+
+ $maybe n <- (next pagination)
+
+ $maybe p <- (previous pagination)
+
+
+ ^{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