Support for multiproject builds with nix

- Closes #28
2018-08-29 22:43:44 +03:00
parent d792cb2a81
commit 6865af361d
30 changed files with 199 additions and 15 deletions
--- a/backend/src/Database/Book.hs
+++ b/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
--- a/backend/src/Database/Channel.hs
+++ b/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)
--- a/backend/src/Database/Schema.hs
+++ b/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)
--- a/backend/src/Database/Tag.hs
+++ b/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)
+
--- a/backend/src/Database/User.hs
+++ b/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