Try out the book schema
This commit is contained in:
parent
93fe3a573d
commit
ac82f6973b
@ -9,7 +9,9 @@ import Database.Selda.Generic
|
|||||||
import Database.Selda
|
import Database.Selda
|
||||||
import Database.Selda.Backend
|
import Database.Selda.Backend
|
||||||
|
|
||||||
data User pass = User { email :: Text
|
-- | User type
|
||||||
|
data User pass = User { identifier :: RowID
|
||||||
|
, email :: Text
|
||||||
, username :: Text
|
, username :: Text
|
||||||
, role :: Role
|
, role :: Role
|
||||||
, password :: pass }
|
, password :: pass }
|
||||||
@ -26,4 +28,79 @@ instance SqlType Role where
|
|||||||
defaultValue = mkLit minBound
|
defaultValue = mkLit minBound
|
||||||
|
|
||||||
users :: GenTable (User ByteString)
|
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)
|
||||||
|
@ -28,7 +28,7 @@ insertUser username email (PlainPassword password) =
|
|||||||
insertAs role = do
|
insertAs role = do
|
||||||
lift $ $logInfo $ "Inserting new user as " <> pack (show role)
|
lift $ $logInfo $ "Inserting new user as " <> pack (show role)
|
||||||
let bytePass = encodeUtf8 password
|
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)
|
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
|
adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
|
||||||
@ -38,7 +38,7 @@ adminExists = do
|
|||||||
return $ maybe False (> 0) . listToMaybe $ r
|
return $ maybe False (> 0) . listToMaybe $ r
|
||||||
where
|
where
|
||||||
q = aggregate $ do
|
q = aggregate $ do
|
||||||
(_ :*: _ :*: r :*: _) <- select (gen users)
|
(_ :*: _ :*: _ :*: r :*: _) <- select (gen users)
|
||||||
restrict (r .== literal AdminRole)
|
restrict (r .== literal AdminRole)
|
||||||
return (count r)
|
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
|
getUser' name = over (_Just . field @"password") HashedPassword . listToMaybe . fmap fromRel <$> query q
|
||||||
where
|
where
|
||||||
q = do
|
q = do
|
||||||
u@(username :*: _ :*: _ :*: _) <- select (gen users)
|
u@(_ :*: username :*: _ :*: _ :*: _) <- select (gen users)
|
||||||
restrict (username .== literal name)
|
restrict (username .== literal name)
|
||||||
return u
|
return u
|
||||||
|
@ -41,6 +41,12 @@ develMain = do
|
|||||||
where
|
where
|
||||||
migrate = do
|
migrate = do
|
||||||
tryCreateTable (gen users)
|
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 (IORef a) -> (a -> IO a) -> IO ()
|
||||||
modifyStoredIORef store f = withStore store $ \ref -> do
|
modifyStoredIORef store f = withStore store $ \ref -> do
|
||||||
|
Loading…
Reference in New Issue
Block a user