ebook-manager/src/API/Catalogue.hs

{-# 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)
  getBooks :: Channel.ChannelID -> SafeUser -> m (Catalog v)

instance VersionedCatalog AppM 1 where
  getChannels = getChannelsV1
  getBooks = getBooksV1

getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
getBooksV1 identifier SafeUser{} = do
  updated <- liftIO getCurrentTime
  let self = Rel ("/api/current" <> selfUrl)
      start = Rel ("/api/current" <> startUrl)
      selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
      startUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
      entries = mempty
      pagination = Pagination Nothing Nothing
  pure CatalogV1{..}


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

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 identifier = flip requireLoggedIn auth (getBooks identifier)
    catalogRoot :: AppM (Catalog v)
    -- catalog root returns channels
    catalogRoot = flip requireLoggedIn auth getChannels