MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Docs support

Browse Source
This commit is contained in:
Mats Rauhala
2018-11-12 21:32:42 +02:00
parent 7928aa1cb6
commit 5727ea5574
10 changed files with 235 additions and 168 deletions
Download Patch File Download Diff File Expand all files Collapse all files

83
backend/src/Database/Schema.hs
View File

@ -1,80 +1,89 @@
{-# Language NoImplicitPrelude #-}
{-# Language DeriveGeneric #-}
{-# Language OverloadedStrings #-}
{-# Language DuplicateRecordFields #-}
{-# Language GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Database.Schema where
import ClassyPrelude
import Database.Selda.Generic
import Database.Selda
import Database.Selda.Backend
import Data.Aeson
import Web.HttpApiData
import ClassyPrelude
import Data.Aeson
import Database.Selda
import Database.Selda.Backend
import Database.Selda.Generic
import qualified Servant.Docs as Docs
import Web.HttpApiData
-- | User type
newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic)
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq)
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq, IsString)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic)
newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic, IsString)
instance Docs.ToSample Username where
toSamples _ = [("Username", Username "user123")]
instance Docs.ToSample Email where
toSamples _ = [("Email", Email "first.last@example.com")]
instance Docs.ToSample PlainPassword where
toSamples _ = [("Password", PlainPassword "password123")]
instance SqlType HashedPassword where
mkLit = LCustom . LBlob . unHashed
fromSql (SqlBlob x) = HashedPassword x
fromSql _ = error "fromSql: Bad hash"
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"
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"
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, Generic)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic, Num)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic)
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic, Num)
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"
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"
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"
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"
fromSql _ = error "fromSql: Bad tagid"
defaultValue = mkLit (TagID (-1))
data User pass = User { identifier :: UserID
, email :: Email
, username :: Username
, role :: Role
, password :: pass }
, email :: Email
, username :: Username
, role :: Role
, password :: pass }
deriving (Show, Generic)
data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic, Eq)
@ -98,18 +107,18 @@ users = genTable "users" [ (email :: User HashedPassword -> Email) :- uniqueGen
-- | Book type
newtype HashDigest = HashDigest { unHex :: ByteString } deriving Show
-- XXX: Add an identifier for the book
data Book = Book { identifier :: BookID
data Book = Book { identifier :: BookID
, contentHash :: Maybe HashDigest
, contentType :: Text
, title :: Text
, title :: Text
, description :: Maybe Text
, owner :: UserID }
, 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"
fromSql _ = error "fromSql: Not a valid hash digest"
defaultValue = mkLit (HashDigest "") -- Doesn't really make sense
books :: GenTable Book
@ -120,8 +129,8 @@ books = genTable "books" [ (identifier :: Book -> BookID) :- autoPrimaryGen
-- | Categorizing books
data Tag = Tag { identifier :: TagID
, tag :: Text
, owner :: UserID }
, tag :: Text
, owner :: UserID }
deriving (Show, Generic)
data Visibility = Public | Private | Followers
@ -137,8 +146,8 @@ instance SqlType Visibility where
defaultValue = mkLit Private
data Channel = Channel { identifier :: ChannelID
, channel :: Text
, owner :: UserID
, channel :: Text
, owner :: UserID
, visibility :: Visibility }
deriving (Show, Generic)
@ -154,12 +163,12 @@ channels = genTable "channels" [ (identifier :: Channel -> ChannelID) :- autoPri
where
i :*: _ = selectors (gen users)
data BookTag = BookTag { tag :: TagID
data BookTag = BookTag { tag :: TagID
, book :: BookID }
deriving (Show, Generic)
data BookChannel = BookChannel { channel :: ChannelID
, book :: BookID }
, book :: BookID }
deriving (Show, Generic)
bookTags :: GenTable BookTag