Compare commits

...

2 Commits

Author SHA1 Message Date
26af45713c Travis build 2018-11-12 21:46:42 +02:00
5727ea5574 Docs support 2018-11-12 21:32:42 +02:00
11 changed files with 251 additions and 168 deletions

16
.travis.yml Normal file
View File

@ -0,0 +1,16 @@
language: nix
os:
- linux
before_script:
- mkdir -m 0755 -p /nix/var/nix/{profiles,gcroots}/per-user/$USER
- mkdir -p ~/.config/nixpkgs
script:
- nix build -f release.nix backend
cache:
directories:
- nix

View File

@ -68,6 +68,7 @@ executable backend
, servant , servant
, servant-auth , servant-auth
, servant-auth-server , servant-auth-server
, servant-auth-docs
, servant-docs , servant-docs
, servant-lucid , servant-lucid
, servant-multipart , servant-multipart
@ -124,6 +125,7 @@ test-suite spec
, servant-auth , servant-auth
, servant-auth-server , servant-auth-server
, servant-docs , servant-docs
, servant-auth-docs
, servant-lucid , servant-lucid
, servant-multipart , servant-multipart
, servant-server , servant-server

View File

@ -25,16 +25,14 @@ import qualified API.Catalogue as Catalogue
data Index = Index data Index = Index
type API = Get '[HTML] (AppView Index) type API = Users.API
:<|> Users.API
:<|> "api" :> "current" :> Channels.API :<|> "api" :> "current" :> Channels.API
:<|> "api" :> "current" :> Books.API :<|> "api" :> "current" :> Books.API
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1 :<|> "api" :> "1" :> Catalogue.VersionedAPI 1
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1 :<|> "api" :> "current" :> Catalogue.VersionedAPI 1
handler :: ServerT API AppM handler :: ServerT API AppM
handler = indexHandler handler = Users.handler
:<|> Users.handler
:<|> Channels.handler :<|> Channels.handler
:<|> Books.handler :<|> Books.handler
:<|> Catalogue.handler :<|> Catalogue.handler

View File

@ -1,53 +1,58 @@
{-# Language DuplicateRecordFields #-} {-# LANGUAGE DataKinds #-}
{-# Language DataKinds #-} {-# LANGUAGE DeriveGeneric #-}
{-# Language TypeFamilies #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# Language TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}
{-# Language NoImplicitPrelude #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# Language MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-}
{-# Language TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# Language QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}
{-# Language RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-}
{-# Language DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-}
{-# Language FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-}
{-# Language TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# Language DataKinds #-} {-# LANGUAGE TypeFamilies #-}
{-# Language NamedFieldPuns #-} {-# LANGUAGE TypeOperators #-}
module API.Books where module API.Books where
import ClassyPrelude import ClassyPrelude
import Control.Lens import Control.Lens
import Control.Monad.Catch (throwM, MonadThrow) import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans.Maybe
import Crypto.Hash (digestFromByteString)
import Data.Aeson import Data.Aeson
import Data.ByteArray (convert)
import Data.Generics.Product import Data.Generics.Product
import Database import Database
import Database.Book import Database.Book
import Database.Channel import Database.Channel
import Database.Tag import Database.Tag
import Servant hiding (contentType) import qualified Datastore as DS
import Servant.Auth as SA import Servant hiding (contentType)
import Servant.Auth as SA
import qualified Servant.Docs as Docs
import Server.Auth import Server.Auth
import Types import Types
import Control.Monad.Trans.Maybe data JsonBook = JsonBook { identifier :: BookID
import qualified Datastore as DS
import Data.ByteArray (convert)
import Crypto.Hash (digestFromByteString)
data JsonBook = JsonBook { identifier :: BookID
, contentType :: Text , contentType :: Text
, title :: Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, channels :: [Text] , channels :: [Text]
, tags :: [Text] } , tags :: [Text] }
deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
instance Docs.ToSample JsonBook where
toSamples _ = [("Book", JsonBook 13 "epub" "title" (Just "Description") [] [])]
instance Docs.ToSample PostBook where
toSamples _ = [("Book", PostBook "epub" "title" (Just "Description") [] [])]
data PostBook = PostBook { contentType :: Text data PostBook = PostBook { contentType :: Text
, title :: Text , title :: Text
, description :: Maybe Text , description :: Maybe Text
, channels :: [Text] , channels :: [Text]
, tags :: [Text] } , tags :: [Text] }
deriving (Generic, Show, Eq) deriving (Generic, Show, Eq)
@ -58,13 +63,21 @@ instance FromJSON PostBook
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "book_id" BookID) where
toCapture _ = Docs.DocCapture "book_id" "The book id"
type BaseAPI = "books" :> Get '[JSON] [JsonBook] type BaseAPI = "books" :> Get '[JSON] [JsonBook]
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook :<|> "books" :> Capture "book_id" BookID :> "meta" :> ReqBody '[JSON] JsonBook :> Put '[JSON] JsonBook
:<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent :<|> "books" :> Capture "book_id" BookID :> ReqBody '[OctetStream] FileContent :> Put '[JSON] NoContent
:<|> GetBook :<|> GetBook
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString newtype FileContent = FileContent { getFileContent :: ByteString } deriving (MimeUnrender OctetStream, MimeRender OctetStream )
instance Docs.ToSample FileContent where
toSamples _ = [("File contents", FileContent "bytes here and there")]
type GetBook = "books" :> Capture "book_id" BookID :> Get '[OctetStream] FileContent
handler :: ServerT API AppM handler :: ServerT API AppM
handler user = listBooksHandler user handler user = listBooksHandler user
@ -73,12 +86,12 @@ handler user = listBooksHandler user
:<|> putBookContentHandler user :<|> putBookContentHandler user
:<|> getBookContentHandler user :<|> getBookContentHandler user
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM FileContent
getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
content <- runMaybeT $ do content <- runMaybeT $ do
Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username) Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex) contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
MaybeT $ DS.get contentHash FileContent <$> MaybeT (DS.get contentHash)
maybe (throwM err404) return content maybe (throwM err404) return content
requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
@ -87,8 +100,9 @@ requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{usernam
unless exists $ throwM err404 unless exists $ throwM err404
runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403 runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent putBookContentHandler :: AuthResult SafeUser -> BookID -> FileContent -> AppM NoContent
putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do putBookContentHandler auth bookId fc = requireBookOwner auth bookId $ \SafeUser{username} -> do
let content = getFileContent fc
key <- HashDigest . convert <$> DS.put content key <- HashDigest . convert <$> DS.put content
runDB (setContent bookId username key) runDB (setContent bookId username key)
return NoContent return NoContent

View File

@ -24,8 +24,10 @@ import qualified Database.Channel as Channel
import GHC.TypeLits import GHC.TypeLits
import Servant hiding (contentType) import Servant hiding (contentType)
import Servant.Auth as SA import Servant.Auth as SA
import qualified Servant.Docs as Docs
import Servant.XML import Servant.XML
import Server.Auth import Server.Auth
import System.IO.Unsafe (unsafePerformIO)
import Types import Types
-- This is my first try on going to versioned apis, things might change -- This is my first try on going to versioned apis, things might change
@ -40,7 +42,7 @@ newtype Rel = Rel { unRel :: Text } deriving (IsString, Show)
data Pagination = Pagination { previous :: Maybe Rel data Pagination = Pagination { previous :: Maybe Rel
, next :: Maybe Rel } , next :: Maybe Rel }
deriving (Show) deriving (Show, Generic)
newtype SubSection = SubSection Rel deriving (Show) newtype SubSection = SubSection Rel deriving (Show)
newtype Acquisition = Acquisition Rel deriving (Show) newtype Acquisition = Acquisition Rel deriving (Show)
@ -64,6 +66,20 @@ deriving instance Show (Entry 1)
deriving instance Generic (Catalog 1) deriving instance Generic (Catalog 1)
deriving instance Generic (Entry 1) deriving instance Generic (Entry 1)
instance Docs.ToSample (Entry 1) where
toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))]
instance Docs.ToSample UTCTime where
toSamples _ = [("time", docsTime)]
instance Docs.ToSample Rel where
toSamples _ = [("Relative link", Rel "next")]
instance Docs.ToSample Pagination
instance Docs.ToSample (Catalog 1) -- where
-- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])]
docsTime :: UTCTime
docsTime = unsafePerformIO getCurrentTime
instance ToNode SubSection where instance ToNode SubSection where
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|] toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]

View File

@ -1,41 +1,47 @@
{-# Language DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# Language TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-}
{-# Language TypeOperators #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# Language NoImplicitPrelude #-} {-# LANGUAGE FlexibleInstances #-}
{-# Language MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# Language OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-}
{-# Language TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# Language QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-}
{-# Language RecordWildCards #-} {-# LANGUAGE QuasiQuotes #-}
{-# Language DeriveGeneric #-} {-# LANGUAGE RecordWildCards #-}
{-# Language FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-}
{-# Language TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# Language DataKinds #-} {-# LANGUAGE TypeFamilies #-}
{-# Language DuplicateRecordFields #-} {-# LANGUAGE TypeOperators #-}
{-# Language NamedFieldPuns #-}
module API.Channels (API, handler, JsonChannel(..)) where module API.Channels (API, handler, JsonChannel(..)) where
import ClassyPrelude import ClassyPrelude
import Control.Lens import Control.Lens
import Control.Monad.Catch (throwM, MonadThrow) import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import Data.Generics.Product import Data.Generics.Product
import Database import Database
import Database.Channel import Database.Channel
import Servant import Servant
import Servant.Auth as SA import Servant.Auth as SA
import Server.Auth import qualified Servant.Docs as Docs
import Types import Server.Auth
import Types
data JsonChannel = JsonChannel { channel :: Text data JsonChannel = JsonChannel { channel :: Text
, visibility :: Visibility } , visibility :: Visibility }
deriving (Show, Generic) deriving (Show, Generic)
data UpdateChannel = UpdateChannel { identifier :: ChannelID data UpdateChannel = UpdateChannel { identifier :: ChannelID
, channel :: Text , channel :: Text
, visibility :: Visibility } , visibility :: Visibility }
deriving (Show, Generic) deriving (Show, Generic)
instance Docs.ToSample JsonChannel where
toSamples _ = [("Channel", JsonChannel "channel" Private)]
instance Docs.ToSample UpdateChannel where
toSamples _ = [("Channel", UpdateChannel 13 "channel" Private)]
instance ToJSON JsonChannel instance ToJSON JsonChannel
instance FromJSON JsonChannel instance FromJSON JsonChannel
instance ToJSON UpdateChannel instance ToJSON UpdateChannel
@ -43,6 +49,9 @@ instance FromJSON UpdateChannel
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "channel_id" ChannelID) where
toCapture _ = Docs.DocCapture "channel_id" "The channel id"
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
:<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel :<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
:<|> "channels" :> Get '[JSON] [JsonChannel] :<|> "channels" :> Get '[JSON] [JsonChannel]

View File

@ -7,18 +7,19 @@
{-# Language TypeApplications #-} {-# Language TypeApplications #-}
module API.Users where module API.Users where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Catch (throwM, MonadThrow) import Control.Monad.Catch (throwM, MonadThrow)
import Data.Aeson import Data.Aeson
import Database (runDB) import Database (runDB)
import Database.Schema import Database.Schema
import Database.User import Database.User
import Servant import Servant
import Servant.Auth as SA import Servant.Auth as SA
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
import Server.Auth import qualified Servant.Docs as Docs
import Types import Server.Auth
import Web.FormUrlEncoded import Types
import Web.FormUrlEncoded
data RegisterForm = RegisterForm { username :: Username data RegisterForm = RegisterForm { username :: Username
@ -27,12 +28,17 @@ data RegisterForm = RegisterForm { username :: Username
, passwordAgain :: PlainPassword } , passwordAgain :: PlainPassword }
deriving (Generic, Show) deriving (Generic, Show)
instance Docs.ToSample RegisterForm
data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
data RegisterStatus = RegisterStatus deriving Generic data RegisterStatus = RegisterStatus deriving Generic
instance Docs.ToSample RegisterStatus
instance ToJSON LoginStatus instance ToJSON LoginStatus
instance FromJSON LoginStatus instance FromJSON LoginStatus
instance Docs.ToSample LoginStatus
instance FromJSON RegisterForm instance FromJSON RegisterForm
instance ToJSON RegisterForm instance ToJSON RegisterForm

View File

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

View File

@ -1,37 +1,45 @@
{-# Language DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# Language TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-}
{-# Language TypeOperators #-} {-# LANGUAGE FlexibleInstances #-}
{-# Language NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# Language MultiParamTypeClasses #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# Language OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# Language TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}
{-# Language QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}
{-# Language RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# Language DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-}
{-# Language FlexibleInstances #-} {-# LANGUAGE TypeApplications #-}
{-# Language TypeApplications #-} {-# LANGUAGE TypeFamilies #-}
{-# Language ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}
module Server where module Server where
import qualified API as API import qualified API as API
import Server.Auth (authCheck) import ClassyPrelude hiding (Handler)
import Servant import Control.Lens
import Types import Control.Monad.Except
import ClassyPrelude hiding (Handler) import Control.Monad.Logger
import Control.Monad.Logger import Data.Generics.Product
import Control.Monad.Except import Servant
import Servant.Auth.Server as SAS import Servant.Auth.Docs ()
import Control.Lens import Servant.Auth.Server as SAS
import Data.Generics.Product import qualified Servant.Docs as Docs
import Server.Auth (SafeUser) import Servant.HTML.Lucid (HTML)
import Server.Auth (SafeUser)
import Server.Auth (authCheck)
import Types
type API = API.API :<|> "static" :> Raw type API = API.API
:<|> "help" :> Get '[PlainText, HTML] String
:<|> "static" :> Raw
type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings] type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
server :: App -> Application server :: App -> Application
server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDirectoryFileServer "static") server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs :<|> serveDirectoryFileServer "static")
where where
apiDocs :: Docs.API
apiDocs = Docs.docs (Proxy @API.API)
serveDocs = pure $ Docs.markdown apiDocs
myKey = view (field @"jwk") app myKey = view (field @"jwk") app
jwtCfg = defaultJWTSettings myKey jwtCfg = defaultJWTSettings myKey
authCfg = authCheck app authCfg = authCheck app

View File

@ -1,11 +1,11 @@
{-# Language DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# Language TypeFamilies #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# Language OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# Language NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}
{-# Language TypeOperators #-} {-# LANGUAGE TemplateHaskell #-}
{-# Language DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-}
{-# Language TypeApplications #-} {-# LANGUAGE TypeFamilies #-}
{-# Language TemplateHaskell #-} {-# LANGUAGE TypeOperators #-}
module Server.Auth module Server.Auth
( SafeUser(..) ( SafeUser(..)
, authCheck , authCheck
@ -13,29 +13,33 @@ module Server.Auth
, requireLoggedIn) , requireLoggedIn)
where where
import ClassyPrelude import ClassyPrelude
import Control.Lens (view) import Control.Lens (view)
import Control.Monad.Logger import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Catch (throwM, MonadThrow) import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import Data.Generics.Product import Data.Generics.Product
import Database import Database
import Database.Schema import Database.Schema
import Database.User import Database.User
import Servant (err401) import Servant (err401)
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
import Types import qualified Servant.Docs as Docs
import Types
-- generic-lens can convert similar types to this -- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone -- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
-- can open the jwt token and view what's inside, you just can't modify it. -- can open the jwt token and view what's inside, you just can't modify it.
-- --
-- Is it a problem that a human readable username and email are visible? -- Is it a problem that a human readable username and email are visible?
data SafeUser = SafeUser { email :: Email data SafeUser = SafeUser { email :: Email
, username :: Username , username :: Username
, role :: Role } , role :: Role }
deriving (Show, Generic) deriving (Show, Generic)
instance Docs.ToSample SafeUser where
toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )]
instance ToJSON SafeUser where instance ToJSON SafeUser where
instance FromJSON SafeUser where instance FromJSON SafeUser where
instance ToJWT SafeUser where instance ToJWT SafeUser where

View File

@ -0,0 +1 @@
create unique index tag_owner on tags (tag, owner);