From ac82f6973bac7e4b051f0448e658ae86abca30ad Mon Sep 17 00:00:00 2001
From: Mats Rauhala <mats.rauhala@iki.fi>
Date: Sat, 4 Aug 2018 21:30:08 +0300
Subject: [PATCH] Try out the book schema

---
 src/Database/Schema.hs | 81 ++++++++++++++++++++++++++++++++++++++++--
 src/Database/User.hs   |  6 ++--
 src/Devel/Main.hs      |  6 ++++
 3 files changed, 88 insertions(+), 5 deletions(-)

diff --git a/src/Database/Schema.hs b/src/Database/Schema.hs
index bc6a2ab..046d7cd 100644
--- a/src/Database/Schema.hs
+++ b/src/Database/Schema.hs
@@ -9,7 +9,9 @@ import Database.Selda.Generic
 import Database.Selda
 import Database.Selda.Backend
 
-data User pass = User { email :: Text
+-- | User type
+data User pass = User { identifier :: RowID
+                      , email :: Text
                       , username :: Text
                       , role :: Role
                       , password :: pass }
@@ -26,4 +28,79 @@ instance SqlType Role where
   defaultValue = mkLit minBound
 
 users :: GenTable (User ByteString)
-users = genTable "users" [ email :- primaryGen ]
+users = genTable "users" [ (email :: User ByteString -> Text) :- uniqueGen
+                         , username :- uniqueGen
+                         , (identifier :: User ByteString -> RowID) :- autoPrimaryGen ]
+
+-- | Book type
+newtype HashDigest = HashDigest { unHex :: Text } deriving Show
+data Book = Book { contentHash :: HashDigest
+                 , contentType :: Text
+                 , title :: Maybe Text
+                 , description :: Maybe Text }
+          deriving (Show, Generic)
+
+instance SqlType HashDigest where
+  mkLit = LCustom . LText . unHex
+  fromSql (SqlString 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" [ contentHash :- primaryGen ]
+
+data UserBook = UserBook { email :: Text
+                         , book :: HashDigest }
+              deriving (Generic, Show)
+
+userBooks :: GenTable UserBook
+userBooks = genTable "user_book" [ (email :: UserBook -> Text) :- fkGen (gen users) userEmail
+                                 , (book :: UserBook -> HashDigest) :- fkGen (gen books) bookHash ]
+  where
+    _ :*: userEmail :*: _ = selectors (gen users)
+    bookHash :*: _ = selectors (gen books)
+
+-- | Categorizing books
+data Tag = Tag { identifier :: RowID
+               , tag :: Text
+               , owner :: RowID }
+         deriving (Show, Generic)
+
+data Channel = Channel { identifier :: RowID
+                       , channel :: Text
+                       , owner :: RowID }
+             deriving (Show, Generic)
+
+tags :: GenTable Tag
+tags = genTable "tags" [ (identifier :: Tag -> RowID) :- autoPrimaryGen
+                       , (owner :: Tag -> RowID) :- fkGen (gen users) i ]
+  where
+    i :*: _ = selectors (gen users)
+
+channels :: GenTable Channel
+channels = genTable "tags" [ (identifier :: Channel -> RowID) :- autoPrimaryGen
+                           , (owner :: Channel -> RowID) :- fkGen (gen users) i ]
+  where
+    i :*: _ = selectors (gen users)
+
+data BookTag = BookTag { tag :: RowID
+                       , book :: HashDigest }
+             deriving (Show, Generic)
+
+data BookChannel = BookChannel { channel :: RowID
+                               , book :: HashDigest }
+                 deriving (Show, Generic)
+
+bookTags :: GenTable BookTag
+bookTags = genTable "book_tags" [ (tag :: BookTag -> RowID) :- fkGen (gen tags) i
+                                , (book :: BookTag -> HashDigest) :- fkGen (gen books) h ]
+  where
+    i :*: _ = selectors (gen tags)
+    h :*: _ = selectors (gen books)
+
+bookChannels :: GenTable BookChannel
+bookChannels = genTable "book_channels" [ (channel :: BookChannel -> RowID) :- fkGen (gen channels) i
+                                        , (book :: BookChannel -> HashDigest) :- fkGen (gen books) h ]
+  where
+    i :*: _ = selectors (gen channels)
+    h :*: _ = selectors (gen books)
diff --git a/src/Database/User.hs b/src/Database/User.hs
index b3aec14..6c89f68 100644
--- a/src/Database/User.hs
+++ b/src/Database/User.hs
@@ -28,7 +28,7 @@ insertUser username email (PlainPassword password) =
     insertAs role = do
       lift $ $logInfo $ "Inserting new user as " <> pack (show role)
       let bytePass = encodeUtf8 password
-      user <- User email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
+      user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
       insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user)
 
 adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
@@ -38,7 +38,7 @@ adminExists = do
   return $ maybe False (> 0) . listToMaybe $ r
   where
     q = aggregate $ do
-      (_ :*: _ :*: r :*: _) <- select (gen users)
+      (_ :*: _ :*: _ :*: r :*: _) <- select (gen users)
       restrict (r .== literal AdminRole)
       return (count r)
 
@@ -49,6 +49,6 @@ getUser' :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe ( User HashedPas
 getUser' name = over (_Just . field @"password") HashedPassword . listToMaybe . fmap fromRel <$> query q
   where
     q = do
-      u@(username :*: _ :*: _ :*: _) <- select (gen users)
+      u@(_ :*: username :*: _ :*: _ :*: _) <- select (gen users)
       restrict (username .== literal name)
       return u
diff --git a/src/Devel/Main.hs b/src/Devel/Main.hs
index de3fb89..84f579e 100644
--- a/src/Devel/Main.hs
+++ b/src/Devel/Main.hs
@@ -41,6 +41,12 @@ develMain = do
   where
     migrate = do
       tryCreateTable (gen users)
+      tryCreateTable (gen books)
+      tryCreateTable (gen userBooks)
+      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