Support for multiproject builds with nix

- Closes #28

backend/src/API/Books.hs

@@ -0,0 +1,114 @@
+{-# Language DuplicateRecordFields #-}
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language OverloadedStrings #-}
+{-# Language TemplateHaskell #-}
+{-# Language QuasiQuotes #-}
+{-# Language RecordWildCards #-}
+{-# Language DeriveGeneric #-}
+{-# Language FlexibleInstances #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language NamedFieldPuns #-}
+module API.Books where
+
+import Servant hiding (contentType)
+import Types
+import ClassyPrelude
+import Server.Auth
+import Servant.Auth as SA
+import Data.Aeson
+import Database.Book
+import Database.Channel
+import Database.Tag
+import Database
+import Control.Lens
+import Data.Generics.Product
+
+import Control.Monad.Trans.Maybe
+
+import qualified Datastore as DS
+import Data.ByteArray (convert)
+import Crypto.Hash (digestFromByteString)
+
+data JsonBook = JsonBook { identifier :: BookID
+                         , contentType :: Text
+                         , title :: Text
+                         , description :: Maybe Text
+                         , channels :: [Text]
+                         , tags :: [Text] }
+              deriving (Generic, Show)
+
+data PostBook = PostBook { contentType :: Text
+                         , title :: Text
+                         , description :: Maybe Text
+                         , channels :: [Text]
+                         , tags :: [Text] }
+              deriving (Generic, Show)
+
+
+instance ToJSON JsonBook
+instance FromJSON JsonBook
+instance ToJSON PostBook
+instance FromJSON PostBook
+
+type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
+
+type BaseAPI = "books" :> Get '[JSON] [JsonBook]
+       :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
+       :<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
+       :<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent
+       :<|> GetBook
+
+type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
+
+handler :: ServerT API AppM
+handler user = listBooksHandler user
+          :<|> postBookMetaHandler user
+          :<|> putBookMetaHandler user
+          :<|> putBookContentHandler user
+          :<|> getBookContentHandler user
+
+getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString
+getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
+  content <- runMaybeT $ do
+    Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
+    contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
+    MaybeT $ DS.get contentHash
+  maybe (throwM err404) return content
+
+requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
+requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
+  exists <- runDB $ bookExists bookId
+  unless exists $ throwM err404
+  runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
+
+putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent
+putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do
+  key <- HashDigest . convert <$> DS.put content
+  runDB (setContent bookId username key)
+  return NoContent
+
+postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
+postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
+  mIdentifier <- runDB $ insertBook InsertBook{owner=username,..}
+  maybe (throwM err403{errBody="Could not insert book"}) (\identifier -> pure JsonBook{..}) mIdentifier
+
+
+putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
+putBookMetaHandler auth bookId JsonBook{..}
+  | bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} ->
+        maybe (throwM err403) (return . view (super @JsonBook)) =<< runDB (updateBook UpdateBook{..})
+  | otherwise = throwM err403
+
+listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
+listBooksHandler = requireLoggedIn $ \user -> do
+  runDB (usersBooks (view (field @"username") user) >>= mapM augment)
+    where
+      augment Book{identifier=bookId,contentType,title,description} = do
+        channels <- fmap (view (field @"channel")) <$> booksChannels bookId
+        tags <- fmap (view (field @"tag")) <$> booksTags bookId
+        pure JsonBook{identifier=bookId,..}

backend/src/API/Catalogue.hs

@@ -0,0 +1,163 @@
+{-# 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 hiding (contentType)
+import ClassyPrelude
+import GHC.TypeLits
+import Server.Auth
+import Servant.Auth as SA
+import Servant.XML
+import qualified Database.Channel as Channel
+import Database.Book (Book(..))
+import Database
+import qualified API.Books
+
+-- 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
+
+relUrl :: Link -> Rel
+relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
+
+getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
+getBooksV1 channelID SafeUser{username} = do
+  updated <- liftIO getCurrentTime
+  let self = relUrl selfUrl
+      start = relUrl startUrl
+      selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
+      startUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
+      pagination = Pagination Nothing Nothing
+  entries <- map (toEntry updated) <$> runDB (Channel.channelBooks username channelID)
+  pure CatalogV1{..}
+  where
+    toEntry updated Book{description,title,identifier=bookId} =
+      let content = fromMaybe "no content" description
+          identifier = pack . show $ bookId
+          link = Right (Acquisition (relUrl (safeLink (Proxy @API.Books.BaseAPI) (Proxy @API.Books.GetBook) bookId)))
+      in EntryV1{..}
+
+getChannelsV1 :: SafeUser -> AppM (Catalog 1)
+getChannelsV1 SafeUser{username} = do
+  updated <- liftIO getCurrentTime
+  let self = relUrl 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 = 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 = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
+          self = relUrl 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

backend/src/API/Channels.hs

@@ -0,0 +1,75 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language OverloadedStrings #-}
+{-# Language TemplateHaskell #-}
+{-# Language QuasiQuotes #-}
+{-# Language RecordWildCards #-}
+{-# Language DeriveGeneric #-}
+{-# Language FlexibleInstances #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language NamedFieldPuns #-}
+module API.Channels (API, handler, JsonChannel(..)) where
+
+import Servant
+import Types
+import ClassyPrelude
+import Server.Auth
+import Servant.Auth as SA
+import Control.Monad.Logger
+import Database
+import Database.Channel
+import Data.Aeson
+import Control.Lens
+import Data.Generics.Product
+
+data JsonChannel = JsonChannel { channel :: Text
+                               , visibility :: Visibility }
+                 deriving (Show, Generic)
+data UpdateChannel = UpdateChannel { identifier :: ChannelID
+                                   , channel :: Text
+                                   , visibility :: Visibility }
+                 deriving (Show, Generic)
+
+instance ToJSON JsonChannel
+instance FromJSON JsonChannel
+instance ToJSON UpdateChannel
+instance FromJSON UpdateChannel
+
+type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
+
+type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
+          :<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
+          :<|> "channels" :> Get '[JSON] [JsonChannel]
+
+handler :: ServerT API AppM
+handler user = newChannelHandler user :<|> updateChannelHandler user :<|> listChannelsHandler user
+
+requireChannelOwner :: AuthResult SafeUser -> ChannelID -> (SafeUser -> AppM a) -> AppM a
+requireChannelOwner auth channelId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
+  unlessM (runDB . channelExists $ channelId) $ throwM err404
+  runDB (isChannelOwner channelId username) >>= \o -> if o then f u else throwM err403
+
+updateChannelHandler :: AuthResult SafeUser -> ChannelID -> UpdateChannel -> AppM UpdateChannel
+updateChannelHandler auth channelId UpdateChannel{visibility} = requireChannelOwner auth channelId $ \_ -> do
+  mChannel <- fmap toChannel <$> runDB (updateChannelPrivacy channelId visibility)
+  maybe (throwM err403) return mChannel
+
+listChannelsHandler :: AuthResult SafeUser -> AppM [JsonChannel]
+listChannelsHandler = requireLoggedIn $ \user ->
+  -- I could use the super thing from generic-lens, but then I would need to
+  -- use the 'channel' accessor somehow or export it
+  fmap (\Channel{..} -> JsonChannel{..}) <$> runDB (userChannels (view (field @"username") user))
+
+newChannelHandler :: AuthResult SafeUser -> JsonChannel -> AppM UpdateChannel
+newChannelHandler auth JsonChannel{..} = flip requireLoggedIn auth $ \user -> do
+  $logInfo $ "Creating channel for user " <> pack (show user)
+  mChannel <- fmap toChannel <$> runDB (insertChannel (view (field @"username") user) channel visibility)
+  maybe (throwM err403{errBody="Could not create the channel"}) return mChannel
+
+toChannel :: Channel -> UpdateChannel
+toChannel Channel{..} = UpdateChannel{..}

backend/src/API/Users.hs

@@ -0,0 +1,62 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language OverloadedStrings #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language TypeOperators #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language TypeApplications #-}
+module API.Users  where
+
+import Servant
+import ClassyPrelude
+import Types
+import Data.Aeson
+import Web.FormUrlEncoded
+import Database (runDB)
+import Database.User
+import Database.Schema
+import Server.Auth
+import Servant.Auth.Server as SAS
+import Servant.Auth as SA
+
+
+data RegisterForm = RegisterForm { username :: Username
+                                 , email :: Email
+                                 , password :: PlainPassword
+                                 , passwordAgain :: PlainPassword }
+                  deriving (Generic, Show)
+
+data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
+
+data RegisterStatus = RegisterStatus deriving Generic
+
+instance ToJSON LoginStatus
+instance FromJSON LoginStatus
+
+instance FromJSON RegisterForm
+instance ToJSON RegisterForm
+instance ToJSON RegisterStatus
+instance FromJSON RegisterStatus
+instance FromForm RegisterForm
+instance ToForm RegisterForm
+
+
+type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus
+      :<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
+
+handler :: ServerT API AppM
+handler = loginHandler :<|> registerHandler
+
+loginHandler :: AuthResult SafeUser -> AppM LoginStatus
+loginHandler (Authenticated u) = return (LoginStatus (Just u))
+loginHandler _ = return (LoginStatus Nothing)
+
+registerHandler :: RegisterForm -> AppM RegisterStatus
+registerHandler RegisterForm{..} =
+  case () of
+       () | password /= passwordAgain -> noMatch
+          | otherwise ->
+              either (const alreadyExists) (const (pure RegisterStatus)) =<< runDB (insertUser username email password)
+  where
+    noMatch = throwM err403{errBody = "passwords don't match"}
+    alreadyExists = throwM err403{errBody = "User already exists"}