141 lines
4.9 KiB
Haskell
141 lines
4.9 KiB
Haskell
{-# 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 "")
|
|
|
|
|
|
data User pass = User { identifier :: RowID
|
|
, 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 -> 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 "channels" [ (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)
|