Support for multiproject builds with nix

- Closes #28

backend/ChangeLog.md

@@ -0,0 +1,5 @@
+# Revision history for backend
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

backend/LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2018, Mats Rauhala
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Mats Rauhala nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

backend/Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

backend/backend.cabal

@@ -0,0 +1,86 @@
+-- Initial backend.cabal generated by cabal init.  For further
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                backend
+version:             0.1.0.0
+-- synopsis:
+-- description:
+license:             BSD3
+license-file:        LICENSE
+author:              Mats Rauhala
+maintainer:          mats.rauhala@iki.fi
+-- copyright:
+category:            Web
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+executable backend
+  main-is:             Main.hs
+  other-modules:       Devel.Main
+                     , API
+                     , API.Books
+                     , API.Catalogue
+                     , API.Channels
+                     , API.Users
+                     , Database
+                     , Database.Book
+                     , Database.Channel
+                     , Database.Tag
+                     , Database.Schema
+                     , Database.User
+                     , Datastore
+                     , Servant.XML
+                     , Server
+                     , Server.Auth
+                     , Types
+                     , View
+  -- other-extensions:
+  build-depends:       base >=4.10 && <4.11
+                     , common
+                     , aeson
+                     , asn1-data
+                     , asn1-types
+                     , bytestring
+                     , classy-prelude
+                     , cryptonite
+                     , dhall
+                     , directory
+                     , foreign-store
+                     , generic-lens
+                     , http-api-data
+                     , http-media
+                     , jose
+                     , lens
+                     , lucid
+                     , memory
+                     , monad-logger
+                     , mtl
+                     , pandoc
+                     , pandoc-types
+                     , pem
+                     , process
+                     , resource-pool
+                     , selda
+                     , selda-postgresql
+                     , servant
+                     , servant-auth
+                     , servant-auth-server
+                     , servant-docs
+                     , servant-lucid
+                     , servant-multipart
+                     , servant-server
+                     , text
+                     , transformers
+                     , wai
+                     , warp
+                     , x509
+                     , x509-store
+                     , xml-conduit
+                     , xml-hamlet
+  hs-source-dirs:      src
+  default-language:    Haskell2010
+  default-extensions:  DeriveGeneric
+                     , NoImplicitPrelude
+                     , OverloadedStrings
+                     , RecordWildCards

backend/src/API.hs

@@ -0,0 +1,50 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language OverloadedStrings #-}
+{-# Language TemplateHaskell #-}
+{-# Language QuasiQuotes #-}
+{-# Language RecordWildCards #-}
+{-# Language DeriveGeneric #-}
+{-# Language FlexibleInstances #-}
+module API (API, handler) where
+
+
+import Servant
+import Servant.HTML.Lucid (HTML)
+import Types
+
+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
+      :<|> "api" :> "current" :> Channels.API
+      :<|> "api" :> "current" :> 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
+    h1_ [class_ "title"] "Home page"
+    p_ [class_ "subtitle"] "Hello world"
+  toHtmlRaw = toHtml
+
+indexHandler :: AppM (AppView Index)
+indexHandler = mkView "Home" Index

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

backend/src/Database.hs

@@ -0,0 +1,32 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
+{-# Language ConstraintKinds #-}
+module Database
+  ( DBLike
+  , runDB
+  , query
+  , select
+  , gen
+  , fromRel
+  , fromRels
+  , toRel
+  , transaction
+  , SeldaT )
+  where
+
+import Data.Generics.Product
+import Control.Lens (view)
+import Data.Pool (Pool, withResource)
+import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
+import Database.Selda (query, select, transaction)
+import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
+import ClassyPrelude
+
+type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))
+
+runDB :: DBLike r m => SeldaT m a -> m a
+runDB q = do
+  pool <- view (field @"database")
+  withResource pool $ \conn ->
+    runSeldaT q conn

backend/src/Database/Book.hs

@@ -0,0 +1,132 @@
+{-# Language TypeApplications #-}
+{-# Language TypeOperators #-}
+{-# Language DataKinds #-}
+{-# Language DuplicateRecordFields #-}
+module Database.Book
+  ( def
+  , insertBook
+  , getBook
+  , bookExists
+  , updateBook
+  , isBookOwner
+  , setContent
+  , InsertBook(..)
+  , UpdateBook(..)
+  , usersBooks
+  , Book(..)
+  , HashDigest(..)
+  , BookID) where
+
+import ClassyPrelude
+import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
+import Database
+import Database.Selda
+import Database.Selda.Generic
+
+import Control.Lens (view)
+import Data.Generics.Product
+
+import Database.Tag (booksTags, attachTag, clearTags)
+import Database.Channel (booksChannels, attachChannel, clearChannels)
+
+usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book]
+usersBooks username = fromRels <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      book@(_ :*: digest :*: _ :*: _ :*: _ :*: owner) <- select (gen books)
+      restrict (username' .== literal username)
+      restrict (userId .== owner)
+      restrict (not_ (isNull digest))
+      return book
+
+
+getBook :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> m (Maybe Book)
+getBook identifier owner = listToMaybe . fromRels <$> query q
+  where
+    q = do
+      _ :*: bookId <- bookOwner' identifier owner
+      book@(bookId' :*: _) <- select (gen books)
+      restrict (bookId .== bookId')
+      return book
+
+data InsertBook = InsertBook { contentType :: Text
+                             , title :: Text
+                             , description :: Maybe Text
+                             , owner :: Username }
+
+-- Always inserts
+insertBook :: (MonadSelda m, MonadMask m, MonadIO m) => InsertBook -> m (Maybe BookID)
+insertBook InsertBook{..} = do
+  mUserId <- query $ do
+    userId :*: _ :*: username' :*: _ <- select (gen users)
+    restrict (username' .== literal owner)
+    return userId
+  forM (listToMaybe mUserId) $ \userId -> do
+    let book = Book{owner=userId,identifier=def,contentHash=Nothing,..}
+    BookID . fromRowId <$> insertGenWithPK books [book]
+
+data UpdateBook = UpdateBook { identifier :: BookID
+                             , contentType :: Text
+                             , title :: Text
+                             , description :: Maybe Text
+                             , owner :: Username
+                             , tags :: [Text]
+                             , channels :: [Text] }
+                deriving (Show, Generic)
+
+bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool
+bookExists identifier = not . null <$> query q
+  where
+    q = do
+      (bookId :*: _) <- select (gen books)
+      restrict (bookId .== literal identifier)
+      return bookId
+
+isBookOwner :: (MonadSelda m, MonadIO m, MonadThrow m) => BookID -> Username -> m Bool
+isBookOwner identifier username = not . null <$> query (bookOwner' identifier username)
+
+bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
+bookOwner' identifier username = do
+  userId :*: _ :*: username' :*: _ <- select (gen users)
+  bookId :*: _ :*: _ :*: _ :*: _ :*: bookOwner <- select (gen books)
+  restrict (userId .== bookOwner)
+  restrict (username' .== literal username)
+  restrict (bookId .== literal identifier)
+  return (userId :*: bookId)
+
+updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
+updateBook UpdateBook{..} = do
+  clearTags identifier >> connectTags
+  clearChannels identifier >> connectChannels
+  updateBook'
+  getUpdateBook identifier owner
+  where
+    connectTags = mapM_ (attachTag owner identifier) tags
+    connectChannels = mapM_ (attachChannel owner identifier) channels
+    updateBook' = do
+      mUserId <- query (bookOwner' identifier owner)
+      forM_ (listToMaybe mUserId) $ \_userId -> do
+        update_ (gen books) predicate (\b -> b `with` [ pContentType := literal contentType
+                                                      , pTitle := literal title
+                                                      , pDescription := literal description ])
+    _ :*: _ :*: pContentType :*: pTitle :*: pDescription :*: _ = selectors (gen books)
+    predicate (bookId :*: _) = bookId .== literal identifier
+
+
+getUpdateBook :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook)
+getUpdateBook bookId username = do
+  mBook <- getBook bookId username
+  forM mBook $ \Book{..} -> do
+    channels <- map (view (field @"channel")) <$> booksChannels bookId
+    tags <- map (view (field @"tag")) <$> booksTags bookId
+    return UpdateBook{owner=username,..}
+
+setContent :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> HashDigest -> m ()
+setContent identifier owner digest = do
+  mOwner <- query (bookOwner' identifier owner)
+  void $ forM (listToMaybe mOwner) $ \_ ->
+    update_ (gen books) predicate (\b -> b `with` [ pHash := literal (Just digest)])
+  where
+    _ :*: pHash :*: _ = selectors (gen books)
+    predicate (bookId :*: _) = bookId .== literal identifier

backend/src/Database/Channel.hs

@@ -0,0 +1,127 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language NamedFieldPuns #-}
+module Database.Channel
+  ( userChannels
+  , insertChannel
+  , channelExists
+  , isChannelOwner
+  , updateChannelPrivacy
+  , attachChannel
+  , Visibility(..)
+  , clearChannels
+  , booksChannels
+  , channelBooks
+  , Channel(..)
+  , ChannelID(..) )
+  where
+
+import ClassyPrelude
+import Database.Schema
+import Database
+import Database.Selda
+import Database.Selda.Generic
+
+import Control.Monad.Trans.Maybe
+
+getChannel :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m (Maybe Channel)
+getChannel identifier = listToMaybe . fromRels <$> query q
+  where
+    q = do
+      ch@(channelId :*: _) <- select (gen channels)
+      restrict (channelId .== literal identifier)
+      return ch
+
+channelExists :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m Bool
+channelExists identifier = not . null <$> getChannel identifier
+
+isChannelOwner :: (MonadSelda m, MonadIO m, MonadMask m) => ChannelID -> Username -> m Bool
+isChannelOwner identifier username = not . null <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      channelId :*: _ :*: channelOwner :*: _ <- select (gen channels)
+      restrict (userId .== channelOwner)
+      restrict (username' .== literal username)
+      restrict (channelId .== literal identifier)
+      return channelId
+
+userChannels :: (MonadMask m, MonadIO m) => Username -> SeldaT m [Channel]
+userChannels username = fromRels <$> query q
+  where
+    q = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      channel@(_ :*: _ :*: owner :*: _) <- select (gen channels)
+      restrict (owner .== userId)
+      restrict (username' .== literal username)
+      return channel
+
+updateChannelPrivacy :: (MonadMask m, MonadIO m, MonadSelda m) => ChannelID -> Visibility -> m (Maybe Channel)
+updateChannelPrivacy channelId visibility = do
+  void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility])
+  getChannel channelId
+  where
+    predicate (channelId' :*: _) = channelId' .== literal channelId
+    _ :*: _ :*: _ :*: pVis = selectors (gen channels)
+
+insertChannel :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> Visibility -> m (Maybe Channel)
+insertChannel username channel visibility = runMaybeT $ do
+  userId <- MaybeT (listToMaybe <$> getUser)
+  channelId <- toChannelId <$> MaybeT (insertUnless (gen channels) (doesNotExist userId) [ def :*: channel :*: userId :*: visibility ])
+  MaybeT (listToMaybe . fromRels <$> query (q channelId))
+  where
+    q channelId = do
+      ch@(channelId' :*: _) <- select (gen channels)
+      restrict (channelId' .== literal channelId)
+      return ch
+    toChannelId = ChannelID . fromRowId
+    doesNotExist userId (_ :*: channel' :*: userId' :*: _) = channel' .== literal channel .&& userId' .== literal userId
+    getUser = query $ do
+      userId :*: _ :*: user :*: _ <- select (gen users)
+      restrict (user .== literal username)
+      return userId
+
+channelBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> ChannelID -> m [Book]
+channelBooks username identifier = fromRels <$> query q
+  where
+    q = do
+      channelId :*: bookId' <- select (gen bookChannels)
+      channelId' :*: _ :*: owner :*: _ <- select (gen channels)
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      book@(bookId :*: _) <- select (gen books)
+      restrict (username' .== literal username .&& owner .== userId)
+      restrict (channelId .== literal identifier .&& channelId .== channelId')
+      restrict (bookId .== bookId')
+      return book
+
+booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel]
+booksChannels bookId = fromRels <$> query q
+  where
+    q = do
+      channelId :*: bookId' <- select (gen bookChannels)
+      ch@(channelId' :*: _) <- select (gen channels)
+      restrict (channelId .== channelId')
+      restrict (bookId' .== literal bookId)
+      return ch
+
+attachChannel :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
+attachChannel username bookId channel = do
+  mCh <- fromRels <$> query channelQ
+  forM_ mCh $ \Channel{identifier} ->
+    whenM (null <$> query (attachQ identifier)) $
+      void $ insertGen bookChannels [BookChannel identifier bookId]
+  where
+    attachQ channelId = do
+      (channelId' :*: bookId') <- select (gen bookChannels)
+      restrict (channelId' .== literal channelId .&& bookId' .== literal bookId)
+      return channelId'
+    channelQ = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      ch@(_ :*: channel' :*: owner :*: _) <- select (gen channels)
+      restrict (username' .== literal username)
+      restrict (owner .== userId)
+      restrict (channel' .== literal channel)
+      return ch
+
+clearChannels :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int
+clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId)

backend/src/Database/Schema.hs

@@ -0,0 +1,177 @@
+{-# Language NoImplicitPrelude #-}
+{-# Language DeriveGeneric #-}
+{-# Language OverloadedStrings #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+module Database.Schema where
+
+import ClassyPrelude
+import Database.Selda.Generic
+import Database.Selda
+import Database.Selda.Backend
+
+import Data.Aeson
+import Web.HttpApiData
+
+-- | User type
+newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq)
+newtype HashedPassword = HashedPassword {unHashed :: ByteString}
+data NoPassword = NoPassword
+
+newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
+
+newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
+
+instance SqlType HashedPassword where
+  mkLit = LCustom . LBlob . unHashed
+  fromSql (SqlBlob x) = HashedPassword x
+  fromSql _ = error "fromSql: Bad hash"
+  defaultValue = mkLit (HashedPassword "") -- Makes no sense
+
+instance SqlType Email where
+  mkLit = LCustom . LText . unEmail
+  fromSql (SqlString x) = Email x
+  fromSql _ = error "fromSql: Bad email"
+  defaultValue = mkLit (Email "")
+
+instance SqlType Username where
+  mkLit = LCustom . LText . unUsername
+  fromSql (SqlString x) = Username x
+  fromSql _ = error "fromSql: Bad username"
+  defaultValue = mkLit (Username "")
+
+newtype UserID = UserID {unUserID :: Int} deriving (Show)
+
+newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData)
+
+newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON)
+
+newtype TagID = TagID {unTagID :: Int} deriving (Show)
+
+instance SqlType UserID where
+  mkLit = LCustom . LInt . unUserID
+  fromSql (SqlInt x) = UserID x
+  fromSql _ = error "fromSql: Bad userid"
+  sqlType _ = TRowID
+  defaultValue = mkLit (UserID (-1))
+instance SqlType BookID where
+  mkLit = LCustom . LInt . unBookID
+  fromSql (SqlInt x) = BookID x
+  fromSql _ = error "fromSql: Bad bookid"
+  defaultValue = mkLit (BookID (-1))
+instance SqlType ChannelID where
+  mkLit = LCustom . LInt . unChannelID
+  fromSql (SqlInt x) = ChannelID x
+  fromSql _ = error "fromSql: Bad channelid"
+  defaultValue = mkLit (ChannelID (-1))
+instance SqlType TagID where
+  mkLit = LCustom . LInt . unTagID
+  fromSql (SqlInt x) = TagID x
+  fromSql _ = error "fromSql: Bad tagid"
+  defaultValue = mkLit (TagID (-1))
+
+data User pass = User { identifier :: UserID
+                      , email :: Email
+                      , username :: Username
+                      , role :: Role
+                      , password :: pass }
+          deriving (Show, Generic)
+
+data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic)
+
+instance ToJSON Role
+instance FromJSON Role
+
+instance SqlType Role where
+  mkLit = LCustom . LText . pack . show
+  fromSql sql = case sql of
+                     SqlString x -> fromMaybe (error "fromSql: Not a valid role") . readMay . unpack $ x
+                     _ -> error "fromSql: Not a valid role"
+
+  defaultValue = mkLit minBound
+
+users :: GenTable (User HashedPassword)
+users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen
+                         , username :- uniqueGen
+                         , (identifier :: User HashedPassword -> UserID) :- autoPrimaryGen ]
+
+-- | Book type
+newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
+-- XXX: Add an identifier for the book
+data Book = Book { identifier :: BookID
+                 , contentHash :: Maybe HashDigest
+                 , contentType :: Text
+                 , title :: Text
+                 , description :: Maybe Text
+                 , owner :: UserID }
+          deriving (Show, Generic)
+
+instance SqlType HashDigest where
+  mkLit = LCustom . LBlob . unHex
+  fromSql (SqlBlob x) = HashDigest x
+  fromSql _ = error "fromSql: Not a valid hash digest"
+  defaultValue = mkLit (HashDigest "") -- Doesn't really make sense
+
+books :: GenTable Book
+books = genTable "books" [ (identifier :: Book -> BookID) :- autoPrimaryGen
+                         , (owner :: Book -> UserID) :- fkGen (gen users) userId ]
+  where
+    userId :*: _ = selectors (gen users)
+
+-- | Categorizing books
+data Tag = Tag { identifier :: TagID
+               , tag :: Text
+               , owner :: UserID }
+         deriving (Show, Generic)
+
+data Visibility = Public | Private | Followers
+                deriving (Show, Read, Generic)
+
+instance ToJSON Visibility
+instance FromJSON Visibility
+
+instance SqlType Visibility where
+  mkLit = LCustom . LText . pack . show
+  fromSql (SqlString x) = fromMaybe (error "fromSql: Not a valid visibility token") . readMay . unpack $ x
+  fromSql _             = error "fromSql: Not a valid visibility token"
+  defaultValue = mkLit Private
+
+data Channel = Channel { identifier :: ChannelID
+                       , channel :: Text
+                       , owner :: UserID
+                       , visibility :: Visibility }
+             deriving (Show, Generic)
+
+tags :: GenTable Tag
+tags = genTable "tags" [ (identifier :: Tag -> TagID) :- autoPrimaryGen
+                       , (owner :: Tag -> UserID) :- fkGen (gen users) i ]
+  where
+    i :*: _ = selectors (gen users)
+
+channels :: GenTable Channel
+channels = genTable "channels" [ (identifier :: Channel -> ChannelID) :- autoPrimaryGen
+                               , (owner :: Channel -> UserID) :- fkGen (gen users) i ]
+  where
+    i :*: _ = selectors (gen users)
+
+data BookTag = BookTag { tag :: TagID
+                       , book :: BookID }
+             deriving (Show, Generic)
+
+data BookChannel = BookChannel { channel :: ChannelID
+                               , book :: BookID }
+                 deriving (Show, Generic)
+
+bookTags :: GenTable BookTag
+bookTags = genTable "book_tags" [ (tag :: BookTag -> TagID) :- fkGen (gen tags) i
+                                , (book :: BookTag -> BookID) :- fkGen (gen books) h ]
+  where
+    i :*: _ = selectors (gen tags)
+    h :*: _ = selectors (gen books)
+
+bookChannels :: GenTable BookChannel
+bookChannels = genTable "book_channels" [ (channel :: BookChannel -> ChannelID) :- fkGen (gen channels) i
+                                        , (book :: BookChannel -> BookID) :- fkGen (gen books) h ]
+  where
+    i :*: _ = selectors (gen channels)
+    h :*: _ = selectors (gen books)

backend/src/Database/Tag.hs

@@ -0,0 +1,61 @@
+{-# Language TypeApplications #-}
+{-# Language TypeOperators #-}
+{-# Language DataKinds #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language NamedFieldPuns #-}
+module Database.Tag
+  ( def
+  , booksTags
+  , attachTag
+  , upsertTag
+  , clearTags
+  , Tag(..) ) where
+
+import ClassyPrelude
+import Database.Schema
+import Database
+import Database.Selda
+import Database.Selda.Generic
+import Control.Monad.Trans.Maybe
+
+upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag)
+upsertTag username tag = runMaybeT $ do
+  userId <- MaybeT (listToMaybe <$> query userQ)
+  void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)]
+  MaybeT (listToMaybe . fromRels <$> query (tagQ userId))
+  where
+    predicate userId (_ :*: tag' :*: owner) = tag' .== literal tag .&& owner .== literal userId
+    tagQ userId = do
+      t@(_ :*: tag' :*: owner) <- select (gen tags)
+      restrict (tag' .== literal tag .&& owner .== literal userId)
+      return t
+    userQ = do
+      userId :*: _ :*: username' :*: _ <- select (gen users)
+      restrict (username' .== literal username)
+      return userId
+
+booksTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m [Tag]
+booksTags bookId = fromRels <$> query q
+  where
+    q = do
+      tagId :*: bookId' <- select (gen bookTags)
+      tag@(tagId' :*: _) <- select (gen tags)
+      restrict (tagId .== tagId')
+      restrict (bookId' .== literal bookId)
+      return tag
+
+attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
+attachTag username bookId tag = do
+  maybeT <- upsertTag username tag
+  forM_ maybeT $ \Tag{identifier} -> do
+    whenM (null <$> query (tagQ identifier)) $
+      void $ insertGen bookTags [BookTag identifier bookId]
+  where
+    tagQ tagId = do
+      (tagId' :*: bookId') <- select (gen bookTags)
+      restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
+      return tagId'
+
+clearTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int
+clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId)
+

backend/src/Database/User.hs

@@ -0,0 +1,60 @@
+{-# Language LambdaCase #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language TemplateHaskell #-}
+module Database.User where
+
+import ClassyPrelude
+import Database
+import Database.Schema
+import Database.Selda
+import Control.Lens (view, over, _Just)
+import Data.Generics.Product
+import Crypto.KDF.BCrypt
+import Crypto.Random.Types (MonadRandom)
+import Control.Monad.Logger
+import Control.Monad (mfilter)
+
+data UserExistsError = UserExistsError
+
+
+insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
+insertUser username email (PlainPassword password) =
+  getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
+  where
+    insert' = adminExists >>= \e -> Right <$> if e then insertAs UserRole else insertAs AdminRole
+    insertAs role = do
+      lift $ $logInfo $ "Inserting new user as " <> pack (show role)
+      let bytePass = encodeUtf8 password
+      user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
+      insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user)
+
+adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
+adminExists = do
+  r <- query q
+  lift $ $logInfo $ "Admin users: " <> (pack (show r))
+  return $ maybe False (> 0) . listToMaybe $ r
+  where
+    q = aggregate $ do
+      (_ :*: _ :*: _ :*: r :*: _) <- select (gen users)
+      restrict (r .== literal AdminRole)
+      return (count r)
+
+getUser :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe (User NoPassword))
+getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name
+
+validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword))
+validateUser name (PlainPassword password) =
+  asHidden . mfilter valid <$> getUser' name
+  where
+    valid = validatePassword password' . unHashed . view (field @"password")
+    password' = encodeUtf8 password
+    asHidden = over (_Just . field @"password") (const NoPassword)
+
+getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword ))
+getUser' name = listToMaybe . fmap fromRel <$> query q
+  where
+    q = do
+      u@(_ :*: _ :*: username :*: _ ) <- select (gen users)
+      restrict (username .== literal name)
+      return u

backend/src/Datastore.hs

@@ -0,0 +1,54 @@
+{-# Language TypeFamilies #-}
+{-# Language GeneralizedNewtypeDeriving #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
+{-# Language TypeSynonymInstances #-}
+{-# Language FlexibleInstances #-}
+module Datastore where
+
+import ClassyPrelude
+import Types
+import Crypto.Hash
+import Data.Generics.Product
+import Control.Lens
+import System.Directory (doesFileExist, createDirectoryIfMissing)
+
+-- I might change the implementation at some point
+class Monad m => MonadDS m where
+  type Key m :: *
+
+  put :: ByteString -> m (Key m)
+  get :: Key m -> m (Maybe ByteString)
+
+instance MonadDS AppM where
+  type Key AppM = Digest SHA256
+
+  put = putLocal
+  get = getLocal
+
+putLocal :: ( MonadIO m
+            , HasField' "config" r config
+            , HasField' "store" config store
+            , HasField' "path" store Text
+            , MonadReader r m)
+            => ByteString -> m (Digest SHA256)
+putLocal bs = do
+  store <- unpack <$> view (field @"config" . field @"store" . field @"path")
+  liftIO $ createDirectoryIfMissing True store
+  let key = hashWith SHA256 bs
+  writeFile (store </> show key) bs
+  return key
+
+getLocal :: ( MonadIO m
+            , HasField' "config" r config
+            , HasField' "store" config store
+            , HasField' "path" store Text
+            , MonadReader r m)
+            => Digest SHA256 -> m (Maybe ByteString)
+getLocal key = do
+  store <- unpack <$> view (field @"config" . field @"store" . field @"path")
+  liftIO $ createDirectoryIfMissing True store
+  let file = store </> show key
+  exists <- liftIO $ doesFileExist file
+  if exists then Just <$> readFile file else pure Nothing

backend/src/Devel/Main.hs

@@ -0,0 +1,60 @@
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language FlexibleContexts #-}
+module Devel.Main where
+
+import Prelude
+import Control.Monad.Trans.Reader (runReaderT)
+import Main (withApp, defaultMain)
+import Control.Concurrent
+import Control.Monad (void)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
+import GHC.Word (Word32)
+import Dhall (input, auto)
+
+import Database.Schema
+import Database.Selda (tryCreateTable)
+import Database
+
+update :: IO ()
+update = do
+  lookupStore tidStoreNum >>= maybe setupNew restart
+  where
+    doneStore :: Store (MVar ())
+    doneStore = Store 0
+    setupNew :: IO ()
+    setupNew = do
+      done <- storeAction doneStore newEmptyMVar
+      tid <- start done
+      void $ storeAction (Store tidStoreNum) (newIORef tid)
+    restart tidStore = modifyStoredIORef tidStore $ \tid -> do
+      killThread tid
+      withStore doneStore takeMVar
+      readStore doneStore >>= start
+    start :: MVar () -> IO ThreadId
+    start done = forkFinally develMain (\_ -> putMVar done ())
+
+develMain :: IO ()
+develMain = do
+  conf <- input auto "../config/devel.dhall"
+  withApp conf $ \app -> do
+    void $ runReaderT (runDB migrate) app
+    defaultMain app
+  where
+    migrate = do
+      tryCreateTable (gen users)
+      tryCreateTable (gen books)
+      tryCreateTable (gen tags)
+      tryCreateTable (gen channels)
+      tryCreateTable (gen bookTags)
+      tryCreateTable (gen bookChannels)
+
+modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
+modifyStoredIORef store f = withStore store $ \ref -> do
+  v <- readIORef ref
+  f v >>= writeIORef ref
+
+tidStoreNum :: Word32
+tidStoreNum = 1
+

backend/src/Main.hs

@@ -0,0 +1,38 @@
+{-# Language OverloadedStrings #-}
+{-# Language RecordWildCards #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language TypeApplications #-}
+{-# Language DataKinds #-}
+{-# Language NoImplicitPrelude #-}
+module Main where
+
+import Server (server)
+import Network.Wai.Handler.Warp (run)
+import Types
+import Configuration
+import Dhall (input, auto)
+import ClassyPrelude
+import Control.Lens (view)
+import Data.Generics.Product
+import Data.Pool (createPool)
+import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
+import Servant.Auth.Server (generateKey)
+
+defaultMain :: App -> IO ()
+defaultMain = run 8080 . server
+
+withApp :: Config -> (App -> IO ()) -> IO ()
+withApp config f = do
+  let pgHost = view (field @"database" . field @"host") config
+      pgPort = 5432
+      pgDatabase = view (field @"database" . field @"database") config
+      pgUsername = Just (view (field @"database" . field @"username") config)
+      pgPassword = Just (view (field @"database" . field @"password") config)
+  database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
+  jwk <- generateKey
+  f App{..}
+
+main :: IO ()
+main = do
+  c <- input auto "./config/config.dhall"
+  withApp c defaultMain

backend/src/Servant/XML.hs

@@ -0,0 +1,44 @@
+{-# Language OverloadedStrings #-}
+{-# Language FlexibleInstances #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language TypeApplications #-}
+module Servant.XML
+  ( ToNode(..)
+  , XML
+  , OPDS
+  , Text.Hamlet.XML.xml
+  , iso8601 )
+  where
+
+import Text.XML
+import ClassyPrelude
+import Text.Hamlet.XML
+import Servant
+import Network.HTTP.Media.MediaType
+
+data XML
+
+data OPDS
+
+instance (ToNode a) => MimeRender XML a where
+  mimeRender _ a =
+    let [NodeElement root] = toNode a
+    in renderLBS def (Document (Prologue [] Nothing []) root [])
+
+instance (ToNode a) => MimeRender OPDS a where
+  mimeRender _ a = mimeRender (Proxy @XML) a
+
+instance Accept XML where
+  contentType _ = "application" // "xml" /: ("charset", "utf-8")
+
+instance Accept OPDS where
+  contentType _ = "application" // "atom+xml" /: ("charset", "utf-8") /: ("profile", "opds-catalog")
+
+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

backend/src/Server.hs

@@ -0,0 +1,40 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language MultiParamTypeClasses #-}
+{-# Language OverloadedStrings #-}
+{-# Language TemplateHaskell #-}
+{-# Language QuasiQuotes #-}
+{-# Language RecordWildCards #-}
+{-# Language DeriveGeneric #-}
+{-# Language FlexibleInstances #-}
+{-# Language TypeApplications #-}
+module Server where
+
+import qualified API as API
+import Server.Auth (authCheck)
+import Servant
+import Types
+import ClassyPrelude hiding (Handler)
+import Control.Monad.Logger
+import Control.Monad.Except
+import Servant.Auth.Server as SAS
+import Control.Lens
+import Data.Generics.Product
+
+type API = API.API :<|> "static" :> Raw
+
+
+server :: App -> Application
+server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirectoryFileServer "static")
+  where
+    myKey = view (field @"jwk") app
+    jwtCfg = defaultJWTSettings myKey
+    authCfg = authCheck app
+    cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
+    cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
+    server' :: AppM :~> Servant.Handler
+    server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))
+    api :: Proxy API
+    api = Proxy

backend/src/Server/Auth.hs

@@ -0,0 +1,58 @@
+{-# Language DataKinds #-}
+{-# Language TypeFamilies #-}
+{-# Language OverloadedStrings #-}
+{-# Language NoImplicitPrelude #-}
+{-# Language TypeOperators #-}
+{-# Language DuplicateRecordFields #-}
+{-# Language TypeApplications #-}
+{-# Language TemplateHaskell #-}
+module Server.Auth
+  ( SafeUser(..)
+  , authCheck
+  , AuthResult(..)
+  , requireLoggedIn)
+  where
+
+import ClassyPrelude
+import Servant.Auth.Server as SAS
+import Data.Aeson
+import Database.Schema
+import Database.User
+import Database
+import Types
+import Control.Lens (view)
+import Data.Generics.Product
+import Servant (err401)
+import Control.Monad.Logger
+
+-- generic-lens can convert similar types to this
+-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
+-- can open the jwt token and view what's inside, you just can't modify it.
+--
+-- Is it a problem that a human readable username and email are visible?
+data SafeUser = SafeUser { email :: Email
+                         , username :: Username
+                         , role :: Role }
+              deriving (Show, Generic)
+
+instance ToJSON SafeUser where
+instance FromJSON SafeUser where
+instance ToJWT SafeUser where
+instance FromJWT SafeUser where
+
+type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult SafeUser)
+
+instance FromBasicAuthData SafeUser where
+  fromBasicAuthData authData authCheckFunction = authCheckFunction authData
+
+authCheck :: App -> BasicAuthData -> IO (AuthResult SafeUser)
+authCheck app (BasicAuthData username password) = flip runReaderT app $
+  maybe SAS.Indefinite authenticated <$> runDB (validateUser username' password')
+  where
+    username' = Username $ decodeUtf8 username
+    password' = PlainPassword $ decodeUtf8 password
+    authenticated = SAS.Authenticated . view (super @SafeUser)
+
+requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
+requireLoggedIn f (Authenticated user) = f user
+requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401

backend/src/Types.hs

@@ -0,0 +1,24 @@
+{-# Language NoImplicitPrelude #-}
+{-# Language DeriveGeneric #-}
+{-# Language TypeSynonymInstances #-}
+{-# Language FlexibleInstances #-}
+module Types
+  ( App(..)
+  , AppM
+  -- Figure out how to re-export instances
+  ) where
+
+import ClassyPrelude
+import Control.Monad.Logger
+import Configuration
+import Data.Pool (Pool)
+import Database.Selda.Backend (SeldaConnection)
+import Servant.Auth.Server as SAS ()
+import Crypto.JOSE.JWK (JWK)
+
+data App = App { config :: Config
+               , database :: Pool SeldaConnection
+               , jwk :: JWK }
+         deriving (Generic)
+
+type AppM = LoggingT (ReaderT App IO)

backend/src/View.hs

@@ -0,0 +1,45 @@
+{-# Language NoImplicitPrelude #-}
+module View
+  ( AppView
+  , mkView
+  , ToHtml(..)
+  , module H )
+  where
+
+import ClassyPrelude
+import Server.Auth
+import Lucid (HtmlT, ToHtml(..))
+import Lucid.Html5 as H
+
+-- Idea from stackbuilders
+-- The idea hasn't been fleshed out 100% yet, but basically for every html view
+-- have the endpoint return an @AppView@. Might work with status codes as well
+--
+-- Collect the metadata to the data type and try to manage it automatically
+data AppView view = AppView { content :: view
+                            , title :: Text
+                            , user :: AuthResult SafeUser
+                            } deriving (Generic, Show)
+
+instance (ToHtml view) => ToHtml (AppView view) where
+  toHtml v = bulma v
+  toHtmlRaw = toHtml
+
+-- Not sure if the monad constraint is needed. Maybe in the future?
+mkView :: (Monad m, ToHtml view) => Text -> view -> m (AppView view)
+mkView title content = mkAuthView title content Indefinite
+
+mkAuthView :: (Monad m, ToHtml view) => Text -> view -> AuthResult SafeUser -> m (AppView view)
+mkAuthView title content user = pure AppView{..}
+
+bulma :: (Monad m, ToHtml view) => AppView view -> HtmlT m ()
+bulma AppView{..} = H.doctypehtml_ $ do
+  H.meta_ [ H.name_ "viewport", H.content_ "width=device-width, initial-scale=1" ]
+  H.meta_ [ H.charset_ "utf-8" ]
+  H.title_ "Hello bulma!"
+  H.link_ [ H.rel_ "stylesheet", H.href_ "/static/css/bulma.min.css" ]
+  H.title_ (toHtml title)
+  H.script_ [ H.defer_ "", H.src_ "https://use.fontawesome.com/releases/v5.1.0/js/all.js" ] ("" :: String)
+  H.body_ $ do
+    H.section_ [ H.class_ "section" ] $ do
+      H.div_ [ H.class_ "container" ] $ toHtml content