Compare commits
2 Commits
master
...
sandbox/Ma
Author | SHA1 | Date |
---|---|---|
Mats Rauhala | 8d8b4e0453 | |
Mats Rauhala | 526a2e7ebc |
|
@ -1,6 +1,2 @@
|
|||
dist/
|
||||
config/config.dhall
|
||||
/ctags
|
||||
/TAGS
|
||||
/result*
|
||||
/backend/config
|
||||
|
|
|
@ -1,233 +0,0 @@
|
|||
# stylish-haskell configuration file
|
||||
# ==================================
|
||||
|
||||
# The stylish-haskell tool is mainly configured by specifying steps. These steps
|
||||
# are a list, so they have an order, and one specific step may appear more than
|
||||
# once (if needed). Each file is processed by these steps in the given order.
|
||||
steps:
|
||||
# Convert some ASCII sequences to their Unicode equivalents. This is disabled
|
||||
# by default.
|
||||
# - unicode_syntax:
|
||||
# # In order to make this work, we also need to insert the UnicodeSyntax
|
||||
# # language pragma. If this flag is set to true, we insert it when it's
|
||||
# # not already present. You may want to disable it if you configure
|
||||
# # language extensions using some other method than pragmas. Default:
|
||||
# # true.
|
||||
# add_language_pragma: true
|
||||
|
||||
# Align the right hand side of some elements. This is quite conservative
|
||||
# and only applies to statements where each element occupies a single
|
||||
# line.
|
||||
- simple_align:
|
||||
cases: true
|
||||
top_level_patterns: true
|
||||
records: true
|
||||
|
||||
# Import cleanup
|
||||
- imports:
|
||||
# There are different ways we can align names and lists.
|
||||
#
|
||||
# - global: Align the import names and import list throughout the entire
|
||||
# file.
|
||||
#
|
||||
# - file: Like global, but don't add padding when there are no qualified
|
||||
# imports in the file.
|
||||
#
|
||||
# - group: Only align the imports per group (a group is formed by adjacent
|
||||
# import lines).
|
||||
#
|
||||
# - none: Do not perform any alignment.
|
||||
#
|
||||
# Default: global.
|
||||
align: global
|
||||
|
||||
# The following options affect only import list alignment.
|
||||
#
|
||||
# List align has following options:
|
||||
#
|
||||
# - after_alias: Import list is aligned with end of import including
|
||||
# 'as' and 'hiding' keywords.
|
||||
#
|
||||
# > import qualified Data.List as List (concat, foldl, foldr, head,
|
||||
# > init, last, length)
|
||||
#
|
||||
# - with_alias: Import list is aligned with start of alias or hiding.
|
||||
#
|
||||
# > import qualified Data.List as List (concat, foldl, foldr, head,
|
||||
# > init, last, length)
|
||||
#
|
||||
# - new_line: Import list starts always on new line.
|
||||
#
|
||||
# > import qualified Data.List as List
|
||||
# > (concat, foldl, foldr, head, init, last, length)
|
||||
#
|
||||
# Default: after_alias
|
||||
list_align: after_alias
|
||||
|
||||
# Right-pad the module names to align imports in a group:
|
||||
#
|
||||
# - true: a little more readable
|
||||
#
|
||||
# > import qualified Data.List as List (concat, foldl, foldr,
|
||||
# > init, last, length)
|
||||
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
|
||||
# > init, last, length)
|
||||
#
|
||||
# - false: diff-safe
|
||||
#
|
||||
# > import qualified Data.List as List (concat, foldl, foldr, init,
|
||||
# > last, length)
|
||||
# > import qualified Data.List.Extra as List (concat, foldl, foldr,
|
||||
# > init, last, length)
|
||||
#
|
||||
# Default: true
|
||||
pad_module_names: true
|
||||
|
||||
# Long list align style takes effect when import is too long. This is
|
||||
# determined by 'columns' setting.
|
||||
#
|
||||
# - inline: This option will put as much specs on same line as possible.
|
||||
#
|
||||
# - new_line: Import list will start on new line.
|
||||
#
|
||||
# - new_line_multiline: Import list will start on new line when it's
|
||||
# short enough to fit to single line. Otherwise it'll be multiline.
|
||||
#
|
||||
# - multiline: One line per import list entry.
|
||||
# Type with constructor list acts like single import.
|
||||
#
|
||||
# > import qualified Data.Map as M
|
||||
# > ( empty
|
||||
# > , singleton
|
||||
# > , ...
|
||||
# > , delete
|
||||
# > )
|
||||
#
|
||||
# Default: inline
|
||||
long_list_align: inline
|
||||
|
||||
# Align empty list (importing instances)
|
||||
#
|
||||
# Empty list align has following options
|
||||
#
|
||||
# - inherit: inherit list_align setting
|
||||
#
|
||||
# - right_after: () is right after the module name:
|
||||
#
|
||||
# > import Vector.Instances ()
|
||||
#
|
||||
# Default: inherit
|
||||
empty_list_align: inherit
|
||||
|
||||
# List padding determines indentation of import list on lines after import.
|
||||
# This option affects 'long_list_align'.
|
||||
#
|
||||
# - <integer>: constant value
|
||||
#
|
||||
# - module_name: align under start of module name.
|
||||
# Useful for 'file' and 'group' align settings.
|
||||
list_padding: 4
|
||||
|
||||
# Separate lists option affects formatting of import list for type
|
||||
# or class. The only difference is single space between type and list
|
||||
# of constructors, selectors and class functions.
|
||||
#
|
||||
# - true: There is single space between Foldable type and list of it's
|
||||
# functions.
|
||||
#
|
||||
# > import Data.Foldable (Foldable (fold, foldl, foldMap))
|
||||
#
|
||||
# - false: There is no space between Foldable type and list of it's
|
||||
# functions.
|
||||
#
|
||||
# > import Data.Foldable (Foldable(fold, foldl, foldMap))
|
||||
#
|
||||
# Default: true
|
||||
separate_lists: true
|
||||
|
||||
# Space surround option affects formatting of import lists on a single
|
||||
# line. The only difference is single space after the initial
|
||||
# parenthesis and a single space before the terminal parenthesis.
|
||||
#
|
||||
# - true: There is single space associated with the enclosing
|
||||
# parenthesis.
|
||||
#
|
||||
# > import Data.Foo ( foo )
|
||||
#
|
||||
# - false: There is no space associated with the enclosing parenthesis
|
||||
#
|
||||
# > import Data.Foo (foo)
|
||||
#
|
||||
# Default: false
|
||||
space_surround: false
|
||||
|
||||
# Language pragmas
|
||||
- language_pragmas:
|
||||
# We can generate different styles of language pragma lists.
|
||||
#
|
||||
# - vertical: Vertical-spaced language pragmas, one per line.
|
||||
#
|
||||
# - compact: A more compact style.
|
||||
#
|
||||
# - compact_line: Similar to compact, but wrap each line with
|
||||
# `{-#LANGUAGE #-}'.
|
||||
#
|
||||
# Default: vertical.
|
||||
style: vertical
|
||||
|
||||
# Align affects alignment of closing pragma brackets.
|
||||
#
|
||||
# - true: Brackets are aligned in same column.
|
||||
#
|
||||
# - false: Brackets are not aligned together. There is only one space
|
||||
# between actual import and closing bracket.
|
||||
#
|
||||
# Default: true
|
||||
align: true
|
||||
|
||||
# stylish-haskell can detect redundancy of some language pragmas. If this
|
||||
# is set to true, it will remove those redundant pragmas. Default: true.
|
||||
remove_redundant: true
|
||||
|
||||
# Replace tabs by spaces. This is disabled by default.
|
||||
# - tabs:
|
||||
# # Number of spaces to use for each tab. Default: 8, as specified by the
|
||||
# # Haskell report.
|
||||
# spaces: 8
|
||||
|
||||
# Remove trailing whitespace
|
||||
- trailing_whitespace: {}
|
||||
|
||||
# Squash multiple spaces between the left and right hand sides of some
|
||||
# elements into single spaces. Basically, this undoes the effect of
|
||||
# simple_align but is a bit less conservative.
|
||||
# - squash: {}
|
||||
|
||||
# A common setting is the number of columns (parts of) code will be wrapped
|
||||
# to. Different steps take this into account. Default: 80.
|
||||
columns: 80
|
||||
|
||||
# By default, line endings are converted according to the OS. You can override
|
||||
# preferred format here.
|
||||
#
|
||||
# - native: Native newline format. CRLF on Windows, LF on other OSes.
|
||||
#
|
||||
# - lf: Convert to LF ("\n").
|
||||
#
|
||||
# - crlf: Convert to CRLF ("\r\n").
|
||||
#
|
||||
# Default: native.
|
||||
newline: native
|
||||
|
||||
# Sometimes, language extensions are specified in a cabal file or from the
|
||||
# command line instead of using language pragmas in the file. stylish-haskell
|
||||
# needs to be aware of these, so it can parse the file correctly.
|
||||
#
|
||||
# No language extensions are enabled by default.
|
||||
language_extensions:
|
||||
- DeriveGeneric
|
||||
- NoImplicitPrelude
|
||||
- OverloadedStrings
|
||||
- RecordWildCards
|
||||
# - TemplateHaskell
|
||||
# - QuasiQuotes
|
12
.travis.yml
12
.travis.yml
|
@ -1,12 +0,0 @@
|
|||
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 --option trusted-public-keys "masser-ebook-manager.cachix.org-1:mtFSkQ2MO5MvjUpulZoFKjKUIa8g8CTcdPVuJaPKS1w= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option binary-caches "https://masser-ebook-manager.cachix.org https://cache.nixos.org" ghc.backend ghc.frontend
|
||||
- nix build -f ./release.nix --option trusted-public-keys "masser-ebook-manager.cachix.org-1:mtFSkQ2MO5MvjUpulZoFKjKUIa8g8CTcdPVuJaPKS1w= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option binary-caches "https://masser-ebook-manager.cachix.org https://cache.nixos.org" ghcjs.frontend
|
|
@ -1,2 +0,0 @@
|
|||
**DEPRECATED**
|
||||
[![Build Status](https://travis-ci.org/MasseR/ebook-manager.svg?branch=master)](https://travis-ci.org/MasseR/ebook-manager)
|
|
@ -1,5 +0,0 @@
|
|||
# Revision history for backend
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
|
@ -1,30 +0,0 @@
|
|||
Copyright (c) 2018, Mats Rauhala
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Mats Rauhala nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,30 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module API (API, handler) where
|
||||
|
||||
|
||||
import Servant
|
||||
import Types
|
||||
|
||||
import qualified API.Books as Books
|
||||
import qualified API.Catalogue as Catalogue
|
||||
import qualified API.Channels as Channels
|
||||
import qualified API.Users as Users
|
||||
|
||||
type API = "api" :> Users.API
|
||||
:<|> "api" :> "current" :> Channels.API
|
||||
:<|> "api" :> "current" :> Books.API
|
||||
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1
|
||||
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1
|
||||
|
||||
handler :: ServerT API AppM
|
||||
handler = Users.handler
|
||||
:<|> Channels.handler
|
||||
:<|> Books.handler
|
||||
:<|> Catalogue.handler
|
||||
:<|> Catalogue.handler
|
||||
|
|
@ -1,127 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module API.Books where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Crypto.Hash (digestFromByteString)
|
||||
import Data.Aeson
|
||||
import Data.ByteArray (convert)
|
||||
import Data.Generics.Product
|
||||
import Database
|
||||
import Database.Book
|
||||
import Database.Channel
|
||||
import Database.Tag
|
||||
import qualified Datastore as DS
|
||||
import Servant hiding (contentType)
|
||||
import Servant.Auth as SA
|
||||
import qualified Servant.Docs as Docs
|
||||
import Server.Auth
|
||||
import Types
|
||||
|
||||
data JsonBook = JsonBook { identifier :: BookID
|
||||
, contentType :: Text
|
||||
, title :: Text
|
||||
, description :: Maybe Text
|
||||
, channels :: [Text]
|
||||
, tags :: [Text] }
|
||||
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
|
||||
, title :: Text
|
||||
, description :: Maybe Text
|
||||
, channels :: [Text]
|
||||
, tags :: [Text] }
|
||||
deriving (Generic, Show, Eq)
|
||||
|
||||
|
||||
instance ToJSON JsonBook
|
||||
instance FromJSON JsonBook
|
||||
instance ToJSON PostBook
|
||||
instance FromJSON PostBook
|
||||
|
||||
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
|
||||
|
||||
|
||||
type BaseAPI = "books" :> Get '[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 :> ReqBody '[OctetStream] FileContent :> Put '[JSON] NoContent
|
||||
:<|> GetBook
|
||||
|
||||
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 user = listBooksHandler user
|
||||
:<|> postBookMetaHandler user
|
||||
:<|> putBookMetaHandler user
|
||||
:<|> putBookContentHandler user
|
||||
:<|> getBookContentHandler user
|
||||
|
||||
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM FileContent
|
||||
getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
|
||||
content <- runMaybeT $ do
|
||||
Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
|
||||
contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
|
||||
FileContent <$> MaybeT (DS.get contentHash)
|
||||
maybe (throwM err404) return content
|
||||
|
||||
requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
|
||||
requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
|
||||
exists <- runDB $ bookExists bookId
|
||||
unless exists $ throwM err404
|
||||
runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
|
||||
|
||||
putBookContentHandler :: AuthResult SafeUser -> BookID -> FileContent -> AppM NoContent
|
||||
putBookContentHandler auth bookId fc = requireBookOwner auth bookId $ \SafeUser{username} -> do
|
||||
let content = getFileContent fc
|
||||
key <- HashDigest . convert <$> DS.put content
|
||||
runDB (setContent bookId username key)
|
||||
return NoContent
|
||||
|
||||
postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
|
||||
postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
|
||||
mIdentifier <- runDB $ insertBook InsertBook{owner=username,..}
|
||||
maybe (throwM err403{errBody="Could not insert book"}) (\identifier -> pure JsonBook{..}) mIdentifier
|
||||
|
||||
|
||||
putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
|
||||
putBookMetaHandler auth bookId JsonBook{..}
|
||||
| bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} ->
|
||||
maybe (throwM err403) (return . view (super @JsonBook)) =<< runDB (updateBook UpdateBook{..})
|
||||
| otherwise = throwM err403
|
||||
|
||||
listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
|
||||
listBooksHandler = requireLoggedIn $ \user -> do
|
||||
runDB (usersBooks (view (field @"username") user) >>= mapM augment)
|
||||
where
|
||||
augment Book{identifier=bookId,contentType,title,description} = do
|
||||
channels <- fmap (view (field @"channel")) <$> booksChannels bookId
|
||||
tags <- fmap (view (field @"tag")) <$> booksTags bookId
|
||||
pure JsonBook{identifier=bookId,..}
|
|
@ -1,42 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import ClassyPrelude
|
||||
import Configuration
|
||||
import Control.Lens (view, to)
|
||||
import Data.Generics.Product
|
||||
import Data.Pool (createPool)
|
||||
import Database.Selda.PostgreSQL (PGConnectInfo (..), pgOpen,
|
||||
seldaClose)
|
||||
import Dhall (auto, input)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Servant.Auth.Server (generateKey)
|
||||
import Server (server)
|
||||
import Types
|
||||
import System.Environment (getEnvironment)
|
||||
|
||||
defaultMain :: App -> IO ()
|
||||
defaultMain app = run (view (field @"config" . field @"port" . to fromIntegral) app) $ server app
|
||||
|
||||
withApp :: Config -> (App -> IO ()) -> IO ()
|
||||
withApp config f = do
|
||||
let pgHost = view (field @"database" . field @"host") config
|
||||
pgPort = 5432
|
||||
pgSchema = Nothing
|
||||
pgDatabase = view (field @"database" . field @"database") config
|
||||
pgUsername = Just (view (field @"database" . field @"username") config)
|
||||
pgPassword = Just (view (field @"database" . field @"password") config)
|
||||
database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
|
||||
jwk <- generateKey
|
||||
f App{..}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
path <- fmap pack . lookup "CONF" <$> getEnvironment
|
||||
c <- input auto (fromMaybe "./config/config.dhall" path)
|
||||
withApp c defaultMain
|
|
@ -1,45 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Server where
|
||||
|
||||
import qualified API
|
||||
import ClassyPrelude hiding (Handler)
|
||||
import Control.Lens
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Logger
|
||||
import Data.Generics.Product
|
||||
import Servant
|
||||
import Servant.Auth.Docs ()
|
||||
import Servant.Auth.Server as SAS
|
||||
import qualified Servant.Docs as Docs
|
||||
import Servant.HTML.Lucid (HTML)
|
||||
import Server.Auth (SafeUser, authCheck)
|
||||
import Types
|
||||
|
||||
type API = API.API
|
||||
:<|> "api" :> "help" :> Get '[PlainText, HTML] String
|
||||
|
||||
type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
|
||||
|
||||
server :: App -> Application
|
||||
server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs)
|
||||
where
|
||||
apiDocs :: Docs.API
|
||||
apiDocs = Docs.docs (Proxy @API.API)
|
||||
serveDocs = pure $ Docs.markdown apiDocs
|
||||
myKey = view (field @"jwk") app
|
||||
jwtCfg = defaultJWTSettings myKey
|
||||
authCfg = authCheck app
|
||||
cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
|
||||
cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
|
||||
server' :: AppM a -> Servant.Handler a
|
||||
server' = Handler . ExceptT . try . (`runReaderT` app) . runFileLoggingT "logs/server.log"
|
||||
api :: Proxy API
|
||||
api = Proxy
|
|
@ -1,66 +0,0 @@
|
|||
{-# LANGUAGE TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import API.Books
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Char (isPrint)
|
||||
import Data.GenValidity.Text ()
|
||||
import qualified Data.Text as T
|
||||
import Database.Schema
|
||||
import Prelude
|
||||
import Test.Hspec
|
||||
import Test.Validity
|
||||
import Test.Validity.Aeson
|
||||
|
||||
instance GenUnchecked PlainPassword
|
||||
instance GenValid PlainPassword
|
||||
instance GenInvalid PlainPassword
|
||||
instance Validity PlainPassword
|
||||
instance GenUnchecked Email
|
||||
instance GenValid Email
|
||||
instance GenInvalid Email
|
||||
instance Validity Email
|
||||
instance GenUnchecked Username
|
||||
instance GenValid Username
|
||||
instance GenInvalid Username
|
||||
instance Validity Username
|
||||
instance GenUnchecked BookID
|
||||
instance GenValid BookID
|
||||
instance GenInvalid BookID
|
||||
instance Validity BookID
|
||||
instance GenUnchecked ChannelID
|
||||
instance GenValid ChannelID
|
||||
instance GenInvalid ChannelID
|
||||
instance Validity ChannelID
|
||||
instance GenUnchecked Role
|
||||
instance GenValid Role
|
||||
instance GenInvalid Role
|
||||
instance Validity Role
|
||||
instance GenUnchecked Visibility
|
||||
instance GenValid Visibility
|
||||
instance GenInvalid Visibility
|
||||
instance Validity Visibility
|
||||
instance GenUnchecked JsonBook
|
||||
instance GenValid JsonBook
|
||||
instance GenInvalid JsonBook
|
||||
instance Validity JsonBook
|
||||
instance GenUnchecked PostBook
|
||||
instance GenValid PostBook
|
||||
instance GenInvalid PostBook
|
||||
instance Validity PostBook
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "JSON encoding" $ do
|
||||
jsonSpecOnValid @PlainPassword
|
||||
jsonSpecOnValid @Email
|
||||
jsonSpecOnValid @Username
|
||||
jsonSpecOnValid @BookID
|
||||
jsonSpecOnValid @ChannelID
|
||||
jsonSpecOnValid @Role
|
||||
jsonSpecOnValid @Visibility
|
||||
jsonSpecOnValid @JsonBook
|
||||
jsonSpecOnValid @PostBook
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
|
@ -1,30 +0,0 @@
|
|||
Copyright (c) 2018, Mats Rauhala
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Mats Rauhala nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
@ -1,47 +0,0 @@
|
|||
name: common
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Mats Rauhala
|
||||
maintainer: mats.rauhala@iki.fi
|
||||
-- copyright:
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files: ChangeLog.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
exposed-modules: Data.Versioned
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.10
|
||||
, classy-prelude
|
||||
, generic-lens
|
||||
, lens
|
||||
, mtl
|
||||
, text
|
||||
, transformers
|
||||
hs-source-dirs: src
|
||||
default-extensions: DeriveGeneric
|
||||
, NoImplicitPrelude
|
||||
, OverloadedStrings
|
||||
, RecordWildCards
|
||||
default-language: Haskell2010
|
||||
|
||||
-- test-suite spec
|
||||
-- type: exitcode-stdio-1.0
|
||||
-- main-is: Spec.hs
|
||||
-- hs-source-dirs: src
|
||||
-- build-depends: base >=4.10
|
||||
-- , classy-prelude
|
||||
-- , foreign-store
|
||||
-- , generic-lens
|
||||
-- , lens
|
||||
-- , mtl
|
||||
-- , text
|
||||
-- , transformers
|
||||
-- , validity
|
||||
-- , genvalidity-hspec
|
||||
-- , genvalidity-property
|
||||
-- , hspec
|
|
@ -1,9 +0,0 @@
|
|||
module Main where
|
||||
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "test" $ it "verifies tests work" $ True == True
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
|
@ -1,8 +0,0 @@
|
|||
{ database : { username : Text
|
||||
, password : Text
|
||||
, host : Text
|
||||
, database : Text
|
||||
, migrations : Text }
|
||||
, store : < Filestore : { path : Text } | IPFS : { common : Text } >
|
||||
, port : Integer
|
||||
}
|
|
@ -4,7 +4,5 @@
|
|||
, password = "password"
|
||||
, host = "hostname"
|
||||
, database = "ebook"
|
||||
, migrations = "./migrations"
|
||||
}
|
||||
store = { path = "/tmp/store" }
|
||||
}
|
||||
|
|
70
default.nix
70
default.nix
|
@ -1,62 +1,10 @@
|
|||
{ nixpkgs, haskellPackages }:
|
||||
|
||||
let
|
||||
miso = nixpkgs.fetchFromGitHub {
|
||||
owner = "dmjio";
|
||||
repo = "miso";
|
||||
rev = "630e823dd40a434b73124e12b229a79d9fefb01d";
|
||||
sha256 = "046gdp3ah2lsipfcy89rh20mn08xbhcgrj549v8zzy69j33xjm2l";
|
||||
};
|
||||
miso-jsaddle = super: if haskellPackages.ghc.isGhcjs or false then (super.callPackage (miso + "/miso-ghcjs.nix") {}) else (super.callPackage (miso + "/miso-ghc-jsaddle.nix") {});
|
||||
|
||||
dontCheck = nixpkgs.haskell.lib.dontCheck;
|
||||
|
||||
in
|
||||
|
||||
(import ./project.nix nixpkgs) {
|
||||
haskellPackages = haskellPackages;
|
||||
packages = {
|
||||
common = ./common;
|
||||
backend = ./backend;
|
||||
frontend = ./frontend;
|
||||
};
|
||||
overrides = self: super: {
|
||||
generic-lens = nixpkgs.haskell.lib.dontCheck super.generic-lens;
|
||||
miso = miso-jsaddle super;
|
||||
# doctest = null; # Not compilable with ghcjs
|
||||
# comonad = dontCheck super.comonad;
|
||||
# Glob = dontCheck super.Glob;
|
||||
# SHA = dontCheck super.SHA;
|
||||
# iproute = dontCheck super.iproute;
|
||||
# semigroupoids = dontCheck super.semigroupoids;
|
||||
# wai-app-static = dontCheck super.wai-app-static;
|
||||
# attoparsec = dontCheck super.attoparsec;
|
||||
# http-date = dontCheck super.http-date;
|
||||
# lens = dontCheck super.lens;
|
||||
# unix-time = dontCheck super.unix-time;
|
||||
# http-types = dontCheck super.http-types;
|
||||
# servant = dontCheck super.servant;
|
||||
# servant-server = dontCheck super.servant-server;
|
||||
# servant-auth-docs = dontCheck super.servant-auth-docs;
|
||||
# lens-aeson = dontCheck super.lens-aeson;
|
||||
# word8 = dontCheck super.word8;
|
||||
# http2 = dontCheck super.http2;
|
||||
# wai-extra = dontCheck super.wai-extra;
|
||||
# pgp-wordlist = dontCheck super.pgp-wordlist;
|
||||
# prettyprinter = dontCheck super.prettyprinter;
|
||||
# unliftio = dontCheck super.unliftio;
|
||||
# prettyprinter-ansi-terminal = dontCheck super.prettyprinter-ansi-terminal;
|
||||
# distributive = dontCheck super.distributive;
|
||||
# genvalidity-property = dontCheck super.genvalidity-property;
|
||||
# genvalidity-hspec = dontCheck super.genvalidity-hspec;
|
||||
# genvalidity = dontCheck super.genvalidity;
|
||||
# megaparsec = dontCheck super.megaparsec;
|
||||
# ncurses = null;
|
||||
# haskeline = super.callHackage "haskeline" "0.7.4.2" {};
|
||||
# terminfo = super.callHackage "terminfo" "0.4.1.1" {};
|
||||
};
|
||||
tools = with haskellPackages; [
|
||||
ghcid
|
||||
hasktags
|
||||
];
|
||||
{ mkDerivation, base, stdenv }:
|
||||
mkDerivation {
|
||||
pname = "ebook-manager";
|
||||
version = "0.1.0.0";
|
||||
src = ./.;
|
||||
isLibrary = false;
|
||||
isExecutable = true;
|
||||
executableHaskellDepends = [ base ];
|
||||
license = stdenv.lib.licenses.bsd3;
|
||||
}
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
-- Initial backend.cabal generated by cabal init. For further
|
||||
-- Initial ebook-manager.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: backend
|
||||
name: ebook-manager
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
|
@ -15,9 +15,8 @@ build-type: Simple
|
|||
extra-source-files: ChangeLog.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable backend
|
||||
executable ebook-manager
|
||||
main-is: Main.hs
|
||||
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
other-modules: Devel.Main
|
||||
, API
|
||||
, API.Books
|
||||
|
@ -25,6 +24,7 @@ executable backend
|
|||
, API.Channels
|
||||
, API.Users
|
||||
, Configuration
|
||||
, Data.Versioned
|
||||
, Database
|
||||
, Database.Book
|
||||
, Database.Channel
|
||||
|
@ -38,10 +38,7 @@ executable backend
|
|||
, Types
|
||||
, View
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.10
|
||||
, exceptions
|
||||
, monad-control
|
||||
, common
|
||||
build-depends: base >=4.10 && <4.11
|
||||
, aeson
|
||||
, asn1-data
|
||||
, asn1-types
|
||||
|
@ -70,13 +67,13 @@ executable backend
|
|||
, servant
|
||||
, servant-auth
|
||||
, servant-auth-server
|
||||
, servant-auth-docs
|
||||
, servant-docs
|
||||
, servant-lucid
|
||||
, servant-multipart
|
||||
, servant-server
|
||||
, text
|
||||
, transformers
|
||||
, uuid
|
||||
, wai
|
||||
, warp
|
||||
, x509
|
||||
|
@ -84,68 +81,8 @@ executable backend
|
|||
, xml-conduit
|
||||
, xml-hamlet
|
||||
hs-source-dirs: src
|
||||
default-extensions: DeriveGeneric
|
||||
, NoImplicitPrelude
|
||||
, OverloadedStrings
|
||||
, RecordWildCards
|
||||
default-language: Haskell2010
|
||||
default-extensions: DeriveGeneric
|
||||
, NoImplicitPrelude
|
||||
, OverloadedStrings
|
||||
, RecordWildCards
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Spec.hs
|
||||
hs-source-dirs: src
|
||||
build-depends: base >=4.10
|
||||
, aeson
|
||||
, asn1-data
|
||||
, asn1-types
|
||||
, bytestring
|
||||
, classy-prelude
|
||||
, common
|
||||
, cryptonite
|
||||
, dhall
|
||||
, directory
|
||||
, exceptions
|
||||
, foreign-store
|
||||
, generic-lens
|
||||
, genvalidity-hspec
|
||||
, genvalidity-hspec-aeson
|
||||
, genvalidity-property
|
||||
, genvalidity-text
|
||||
, hspec
|
||||
, http-api-data
|
||||
, http-media
|
||||
, jose
|
||||
, lens
|
||||
, lucid
|
||||
, memory
|
||||
, monad-control
|
||||
, monad-logger
|
||||
, mtl
|
||||
, pandoc
|
||||
, pandoc-types
|
||||
, pem
|
||||
, process
|
||||
, resource-pool
|
||||
, selda
|
||||
, selda-postgresql
|
||||
, servant
|
||||
, servant-auth
|
||||
, servant-auth-docs
|
||||
, servant-auth-server
|
||||
, servant-docs
|
||||
, servant-lucid
|
||||
, servant-multipart
|
||||
, servant-server
|
||||
, text
|
||||
, transformers
|
||||
, validity
|
||||
, wai
|
||||
, warp
|
||||
, x509
|
||||
, x509-store
|
||||
, xml-conduit
|
||||
, xml-hamlet
|
||||
default-extensions: DeriveGeneric
|
||||
, NoImplicitPrelude
|
||||
, OverloadedStrings
|
||||
, RecordWildCards
|
|
@ -1,5 +0,0 @@
|
|||
# Revision history for frontend
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
|
@ -1,30 +0,0 @@
|
|||
Copyright (c) 2018, Mats Rauhala
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Mats Rauhala nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,32 +0,0 @@
|
|||
-- Initial frontend.cabal generated by cabal init. For further
|
||||
-- documentation, see http://haskell.org/cabal/users-guide/
|
||||
|
||||
name: frontend
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Mats Rauhala
|
||||
maintainer: mats.rauhala@iki.fi
|
||||
-- copyright:
|
||||
category: Web
|
||||
build-type: Simple
|
||||
extra-source-files: ChangeLog.md
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable frontend
|
||||
main-is: Main.hs
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.11 && <4.12
|
||||
, common
|
||||
, generic-lens
|
||||
, jsaddle-warp
|
||||
, lens
|
||||
, miso
|
||||
, mtl
|
||||
, servant
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall
|
|
@ -1,93 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
module Main where
|
||||
|
||||
import Control.Lens (over, set)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Data.Generics.Product
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Javascript.JSaddle.Warp
|
||||
import Miso hiding (set)
|
||||
import Miso.String
|
||||
import Servant.API
|
||||
import Servant.Links
|
||||
import Data.Proxy (Proxy(..))
|
||||
|
||||
type API = Home :<|> Login :<|> Register
|
||||
type Home = View Action
|
||||
type Login = "login" :> View Action
|
||||
type Register = "register" :> View Action
|
||||
|
||||
data Action = Add
|
||||
| Subtract
|
||||
| SayHello
|
||||
| HandleURI URI
|
||||
| ChangeURI URI
|
||||
| NoOp
|
||||
|
||||
data Model = Model { counter :: Int
|
||||
, uri :: URI }
|
||||
deriving (Eq, Generic)
|
||||
|
||||
updateModel :: Model -> Action -> Effect Action Model
|
||||
updateModel m = \case
|
||||
Add -> noEff (over (field @"counter") (+1) m)
|
||||
Subtract -> noEff (over (field @"counter") (\x -> x - 1) m)
|
||||
SayHello -> m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
|
||||
HandleURI uri -> noEff (set (field @"uri") uri m)
|
||||
ChangeURI uri -> m <# do
|
||||
liftIO $ putStrLn $ "Pushing uri " <> show uri
|
||||
pushURI uri
|
||||
return $ HandleURI uri
|
||||
NoOp -> noEff m
|
||||
|
||||
viewModel :: Model -> View Action
|
||||
viewModel model = view
|
||||
where
|
||||
view = either (const the404) id $ runRoute @API Proxy handlers uri model
|
||||
handlers = home :<|> login :<|> register
|
||||
home _ = div_ [] [ button_ [ onClick Add ] [ text "+" ]
|
||||
, text (ms (counter model))
|
||||
, button_ [ onClick Subtract ] [ text "-" ]
|
||||
, button_ [ onClick goLogin ] [ text "go login" ]
|
||||
, button_ [ onClick goRegister ] [ text "go register" ]
|
||||
]
|
||||
login _ = div_ [] []
|
||||
register _ = div_ [] [
|
||||
h3_ [] [text "register"]
|
||||
, label_ [] [text "Username"], input_ [id_ "username", name_ "username"]
|
||||
, label_ [] [text "Email"], input_ [id_ "email", name_ "email"]
|
||||
, label_ [] [text "Password"], input_ [id_ "password", name_ "password"]
|
||||
, label_ [] [text "Password again"], input_ [id_ "passwordAgain", name_ "passwordAgain"]
|
||||
, button_ [] [text "Register"]
|
||||
]
|
||||
the404 = div_ [] []
|
||||
|
||||
goLogin, goHome, goRegister :: Action
|
||||
goLogin = goto @Login @API Proxy Proxy
|
||||
goHome = goto @Home @API Proxy Proxy
|
||||
goRegister = goto @Register @API Proxy Proxy
|
||||
|
||||
goto :: (IsElem endpoint api, HasLink endpoint, MkLink endpoint Link ~ Link) => Proxy api -> Proxy endpoint -> Action
|
||||
goto a b = ChangeURI (linkURI (safeLink a b))
|
||||
|
||||
main :: IO ()
|
||||
main = run 8081 $ do
|
||||
model <- mkModel
|
||||
startApp App{..}
|
||||
where
|
||||
mkModel = Model <$> pure 0 <*> getCurrentURI
|
||||
initialAction = SayHello
|
||||
update = flip updateModel
|
||||
view = viewModel
|
||||
subs = [ uriSub HandleURI ]
|
||||
events = defaultEvents
|
||||
mountPoint = Nothing
|
16
ghcjs.patch
16
ghcjs.patch
|
@ -1,16 +0,0 @@
|
|||
diff --git a/lib/boot/shims/src/string.js b/lib/boot/shims/src/string.js
|
||||
index d82f75a..f16e55a 100644
|
||||
--- a/lib/boot/shims/src/string.js
|
||||
+++ b/lib/boot/shims/src/string.js
|
||||
@@ -780,11 +780,7 @@ function h$throwJSException(e) {
|
||||
// adding the Exception dictionary
|
||||
var strVal = e.toString() + '\n' + Array.prototype.join.call(e.stack, '\n');
|
||||
var someE = MK_SOMEEXCEPTION(HS_JSEXCEPTION_EXCEPTION,
|
||||
-#ifdef GHCJS_PROF
|
||||
- MK_JSEXCEPTION(MK_JSVAL(e), h$toHsString(strVal), h$CCS_SYSTEM))
|
||||
-#else
|
||||
MK_JSEXCEPTION(MK_JSVAL(e), h$toHsString(strVal))
|
||||
-#endif
|
||||
);
|
||||
return h$throw(someE, true);
|
||||
}
|
|
@ -1,14 +0,0 @@
|
|||
{ mkDerivation, base, fetchgit, stdenv }:
|
||||
mkDerivation {
|
||||
pname = "jsaddle-warp";
|
||||
version = "0.9.5.0";
|
||||
src = fetchgit {
|
||||
url = "https://github.com/ghcjs/jsaddle.git";
|
||||
rev = "34fe7d61b3f387b81aa748294ac8d993243f53b4";
|
||||
sha256 = "0qdh5qdk23vcp1yp910zgw2hs4zpbx9ig25xgaax0iwj2m1ifh5x";
|
||||
};
|
||||
postUnpack = "sourceRoot+=/jsaddle-warp; echo source root reset to $sourceRoot";
|
||||
libraryHaskellDepends = [ base ];
|
||||
description = "Interface for JavaScript that works with GHCJS and GHC";
|
||||
license = stdenv.lib.licenses.mit;
|
||||
}
|
|
@ -0,0 +1 @@
|
|||
alter table users add column token text null;
|
|
@ -1 +0,0 @@
|
|||
create unique index tag_owner on tags (tag, owner);
|
|
@ -1,7 +1,7 @@
|
|||
{
|
||||
"url": "https://github.com/nixos/nixpkgs.git",
|
||||
"rev": "4507926b80c6b8f73053775ffee17f6781c7e7c8",
|
||||
"rev": "83a5765b1fea2472ec9cf9d179d3efd18b45c77e",
|
||||
"date": "2018-01-08T11:52:28+01:00",
|
||||
"sha256": "068v9xh7d8klk62p2qwr76fyfqfh1bp08xc12x138g5q6pg6yfzb",
|
||||
"sha256": "01rb61dkbzjbwnb3p8lgs03a94f4584199dlr0cwdmqzaxnp506h",
|
||||
"fetchSubmodules": true
|
||||
}
|
||||
|
|
45
project.nix
45
project.nix
|
@ -1,45 +0,0 @@
|
|||
nixpkgs:
|
||||
|
||||
let
|
||||
|
||||
inherit (nixpkgs.lib) mapAttrs mapAttrsToList escapeShellArg optionalString concatStringsSep concatMapStringsSep;
|
||||
|
||||
in
|
||||
|
||||
{ haskellPackages
|
||||
, packages
|
||||
, overrides ? _ : _ : {}
|
||||
, tools ? []
|
||||
}:
|
||||
|
||||
let
|
||||
|
||||
overrides' = nixpkgs.lib.foldr nixpkgs.lib.composeExtensions (_: _: {}) [
|
||||
(self: super: mapAttrs (name: path: self.callCabal2nix name path {}) packages)
|
||||
overrides
|
||||
];
|
||||
haskellPackages' = haskellPackages.extend overrides';
|
||||
packages' = mapAttrs (name: _: haskellPackages'."${name}") packages;
|
||||
mkShell = name: pkg:
|
||||
let
|
||||
n = "${name}-shell";
|
||||
deps = with haskellPackages'; [
|
||||
ghcid
|
||||
cabal-install
|
||||
hasktags
|
||||
(haskellPackages'.ghcWithHoogle (pkgs: pkg.buildInputs ++ pkg.propagatedBuildInputs))
|
||||
];
|
||||
in
|
||||
{
|
||||
name = "${n}";
|
||||
value = nixpkgs.buildEnv {
|
||||
name = "${n}";
|
||||
paths = tools;
|
||||
buildInputs = tools ++ [deps];
|
||||
};
|
||||
};
|
||||
shells = nixpkgs.lib.listToAttrs (mapAttrsToList mkShell packages');
|
||||
|
||||
in
|
||||
|
||||
packages' // shells
|
72
release.nix
72
release.nix
|
@ -1,72 +0,0 @@
|
|||
{ nixpkgs ? import <nixpkgs> {} }:
|
||||
|
||||
let
|
||||
|
||||
jsaddle = nixpkgs.fetchFromGitHub {
|
||||
owner = "ghcjs";
|
||||
repo = "jsaddle";
|
||||
rev = "34fe7d61b3f387b81aa748294ac8d993243f53b4";
|
||||
sha256 = "0qdh5qdk23vcp1yp910zgw2hs4zpbx9ig25xgaax0iwj2m1ifh5x";
|
||||
};
|
||||
config = {
|
||||
packageOverrides = pkgs: with pkgs.haskell.lib; with pkgs.lib; {
|
||||
haskell = pkgs.haskell // {
|
||||
packages = pkgs.haskell.packages // {
|
||||
ghccustom = pkgs.haskell.packages.ghc843.override {
|
||||
overrides = self: super: {
|
||||
jsaddle-warp = dontCheck (super.callPackage (jsaddle + "/jsaddle-warp") {});
|
||||
# jsaddle-warp = super.callPackage ./jsaddle-warp-ghcjs.nix {};
|
||||
jsaddle = dontCheck (super.callPackage (jsaddle + "/jsaddle") {});
|
||||
};
|
||||
};
|
||||
ghcjscustom = pkgs.haskell.packages.ghcjs84.override {
|
||||
overrides = self: super: {
|
||||
doctest = null;
|
||||
comonad = dontCheck (super.comonad);
|
||||
classy-prelude = dontCheck (super.classy-prelude);
|
||||
unliftio = dontCheck (super.unliftio);
|
||||
semigroupoids = dontCheck (super.semigroupoids);
|
||||
lens = dontCheck (super.lens);
|
||||
directory-tree = dontCheck (super.directory-tree);
|
||||
http-types = dontCheck (super.http-types);
|
||||
tasty-quickcheck = dontCheck (super.tasty-quickcheck);
|
||||
scientific = dontCheck (super.scientific);
|
||||
servant = dontCheck (super.servant);
|
||||
jsaddle-warp = super.callPackage ./jsaddle-warp-ghcjs.nix {};
|
||||
ghc = overrideDerivation (super.ghc.override {
|
||||
ghcjsSrc = pkgs.fetchgit {
|
||||
url = "https://github.com/ghcjs/ghcjs.git";
|
||||
rev = "dc190b1bb2453cfa484124e9f335ee3cad1492f7";
|
||||
sha256 = "0dh52gj0f3700zfyrhisy44b6y9p1bsawwrmd5pllpdyw21zd9lw";
|
||||
fetchSubmodules = true;
|
||||
};
|
||||
}) (drv: { patches = (drv.patches or []) ++ [ ./ghcjs.patch ]; });
|
||||
};
|
||||
};
|
||||
};
|
||||
};
|
||||
};
|
||||
};
|
||||
pinnedVersion = nixpkgs.lib.importJSON ./nixpkgs-version.json;
|
||||
pinnedPkgs = import (nixpkgs.fetchFromGitHub {
|
||||
owner = "NixOS";
|
||||
repo = "nixpkgs";
|
||||
inherit (pinnedVersion) rev sha256;
|
||||
}) { inherit config; };
|
||||
ghc = import ./default.nix { nixpkgs = pinnedPkgs; haskellPackages = pinnedPkgs.haskell.packages.ghccustom; };
|
||||
ghcjs = import ./default.nix { nixpkgs = pinnedPkgs; haskellPackages = pinnedPkgs.haskell.packages.ghcjscustom; };
|
||||
inherit (pinnedPkgs) pkgs;
|
||||
|
||||
in
|
||||
|
||||
{
|
||||
inherit ghc ghcjs;
|
||||
deps = pkgs.buildEnv {
|
||||
name = "deps";
|
||||
paths = [
|
||||
(pkgs.haskell.packages.ghccustom.ghcWithPackages (_: ghc.backend.buildInputs ++ ghc.backend.propagatedBuildInputs))
|
||||
(pkgs.haskell.packages.ghcjscustom.ghcWithPackages (_: ghcjs.frontend.buildInputs ++ ghcjs.frontend.propagatedBuildInputs))
|
||||
];
|
||||
buildInputs = [ ];
|
||||
};
|
||||
}
|
|
@ -0,0 +1,50 @@
|
|||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language QuasiQuotes #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
{-# Language DeriveGeneric #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
module API (API, handler) where
|
||||
|
||||
|
||||
import Servant
|
||||
import Servant.HTML.Lucid (HTML)
|
||||
import Types
|
||||
|
||||
import View
|
||||
|
||||
import qualified API.Users as Users
|
||||
import qualified API.Channels as Channels
|
||||
import qualified API.Books as Books
|
||||
import qualified API.Catalogue as Catalogue
|
||||
|
||||
data Index = Index
|
||||
|
||||
type API = Get '[HTML] (AppView Index)
|
||||
:<|> Users.API
|
||||
:<|> "api" :> Channels.API
|
||||
:<|> "api" :> Books.API
|
||||
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1
|
||||
:<|> "api" :> "current" :> Catalogue.VersionedAPI 1
|
||||
|
||||
handler :: ServerT API AppM
|
||||
handler = indexHandler
|
||||
:<|> Users.handler
|
||||
:<|> Channels.handler
|
||||
:<|> Books.handler
|
||||
:<|> Catalogue.handler
|
||||
:<|> Catalogue.handler
|
||||
|
||||
instance ToHtml Index where
|
||||
toHtml _ = do
|
||||
h1_ [class_ "title"] "Home page"
|
||||
p_ [class_ "subtitle"] "Hello world"
|
||||
toHtmlRaw = toHtml
|
||||
|
||||
indexHandler :: AppM (AppView Index)
|
||||
indexHandler = mkView "Home" Index
|
|
@ -0,0 +1,112 @@
|
|||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language QuasiQuotes #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
{-# Language DeriveGeneric #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language TypeApplications #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language NamedFieldPuns #-}
|
||||
module API.Books where
|
||||
|
||||
import Servant hiding (contentType)
|
||||
import Types
|
||||
import ClassyPrelude
|
||||
import Server.Auth
|
||||
import Servant.Auth as SA
|
||||
import Data.Aeson
|
||||
import Database.Book
|
||||
import Database.Channel
|
||||
import Database.Tag
|
||||
import Database
|
||||
import Control.Lens
|
||||
import Data.Generics.Product
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
import qualified Datastore as DS
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (digestFromByteString)
|
||||
|
||||
data JsonBook = JsonBook { identifier :: BookID
|
||||
, contentType :: Text
|
||||
, title :: Maybe Text
|
||||
, description :: Maybe Text
|
||||
, channels :: [Text]
|
||||
, tags :: [Text] }
|
||||
deriving (Generic, Show)
|
||||
|
||||
data PostBook = PostBook { contentType :: Text
|
||||
, title :: Maybe Text
|
||||
, description :: Maybe Text
|
||||
, channels :: [Text]
|
||||
, tags :: [Text] }
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
||||
instance ToJSON JsonBook
|
||||
instance FromJSON JsonBook
|
||||
instance ToJSON PostBook
|
||||
instance FromJSON PostBook
|
||||
|
||||
type API = Auth '[TokenCheck, SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
|
||||
|
||||
type BaseAPI = "books" :> Get '[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 :> ReqBody '[OctetStream] ByteString :> Put '[JSON] NoContent
|
||||
:<|> "books" :> Capture "book_id" BookID :> Get '[OctetStream] ByteString
|
||||
|
||||
handler :: ServerT API AppM
|
||||
handler user = listBooksHandler user
|
||||
:<|> postBookMetaHandler user
|
||||
:<|> putBookMetaHandler user
|
||||
:<|> putBookContentHandler user
|
||||
:<|> getBookContentHandler user
|
||||
|
||||
getBookContentHandler :: AuthResult SafeUser -> BookID -> AppM ByteString
|
||||
getBookContentHandler auth bookId = requireBookOwner auth bookId $ \SafeUser{username} -> do
|
||||
content <- runMaybeT $ do
|
||||
Book{contentHash=mHash} <- MaybeT $ runDB (getBook bookId username)
|
||||
contentHash <- MaybeT $ return (mHash >>= digestFromByteString . unHex)
|
||||
MaybeT $ DS.get contentHash
|
||||
maybe (throwM err404) return content
|
||||
|
||||
requireBookOwner :: AuthResult SafeUser -> BookID -> (SafeUser -> AppM a) -> AppM a
|
||||
requireBookOwner auth bookId f = flip requireLoggedIn auth $ \u@SafeUser{username} -> do
|
||||
exists <- runDB $ bookExists bookId
|
||||
unless exists $ throwM err404
|
||||
runDB (isBookOwner bookId username) >>= \o -> if o then f u else throwM err403
|
||||
|
||||
putBookContentHandler :: AuthResult SafeUser -> BookID -> ByteString -> AppM NoContent
|
||||
putBookContentHandler auth bookId content = requireBookOwner auth bookId $ \SafeUser{username} -> do
|
||||
key <- HashDigest . convert <$> DS.put content
|
||||
runDB (setContent bookId username key)
|
||||
return NoContent
|
||||
|
||||
postBookMetaHandler :: AuthResult SafeUser -> PostBook -> AppM JsonBook
|
||||
postBookMetaHandler auth PostBook{..} = flip requireLoggedIn auth $ \SafeUser{username} -> do
|
||||
mIdentifier <- runDB $ insertBook InsertBook{owner=username,..}
|
||||
maybe (throwM err403{errBody="Could not insert book"}) (\identifier -> pure JsonBook{..}) mIdentifier
|
||||
|
||||
|
||||
putBookMetaHandler :: AuthResult SafeUser -> BookID -> JsonBook -> AppM JsonBook
|
||||
putBookMetaHandler auth bookId JsonBook{..}
|
||||
| bookId == identifier = requireBookOwner auth bookId $ \SafeUser{username=owner} ->
|
||||
maybe (throwM err403) (return . view (super @JsonBook)) =<< runDB (updateBook UpdateBook{..})
|
||||
| otherwise = throwM err403
|
||||
|
||||
listBooksHandler :: AuthResult SafeUser -> AppM [JsonBook]
|
||||
listBooksHandler = requireLoggedIn $ \user -> do
|
||||
runDB (usersBooks (view (field @"username") user) >>= mapM augment)
|
||||
where
|
||||
augment Book{identifier=bookId,contentType,title,description} = do
|
||||
channels <- fmap (view (field @"channel")) <$> booksChannels bookId
|
||||
tags <- fmap (view (field @"tag")) <$> booksTags bookId
|
||||
pure JsonBook{identifier=bookId,..}
|
|
@ -16,19 +16,15 @@
|
|||
{-# Language ScopedTypeVariables #-}
|
||||
module API.Catalogue (VersionedAPI, handler) where
|
||||
|
||||
import qualified API.Books
|
||||
import ClassyPrelude hiding (link)
|
||||
import Database
|
||||
import Database.Book (Book(..))
|
||||
import Types
|
||||
import Servant
|
||||
import ClassyPrelude
|
||||
import GHC.TypeLits
|
||||
import Server.Auth
|
||||
import Servant.Auth as SA
|
||||
import Servant.XML
|
||||
import qualified Database.Channel as Channel
|
||||
import GHC.TypeLits
|
||||
import Servant hiding (contentType)
|
||||
import Servant.Auth as SA
|
||||
import qualified Servant.Docs as Docs
|
||||
import Servant.XML
|
||||
import Server.Auth
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Types
|
||||
import Database
|
||||
|
||||
-- This is my first try on going to versioned apis, things might change
|
||||
-- I think my rule of thumb is that you can add new things as you want, but
|
||||
|
@ -42,20 +38,19 @@ newtype Rel = Rel { unRel :: Text } deriving (IsString, Show)
|
|||
|
||||
data Pagination = Pagination { previous :: Maybe Rel
|
||||
, next :: Maybe Rel }
|
||||
deriving (Show, Generic)
|
||||
deriving (Show)
|
||||
|
||||
newtype SubSection = SubSection Rel deriving (Show)
|
||||
newtype Acquisition = Acquisition Rel deriving (Show)
|
||||
newtype Time = Time { getTime :: UTCTime } deriving Show
|
||||
|
||||
data instance Entry 1 = EntryV1 { title :: Text
|
||||
, identifier :: Text
|
||||
, updated :: Time
|
||||
, updated :: UTCTime
|
||||
, content :: Text
|
||||
, link :: Either SubSection Acquisition
|
||||
}
|
||||
|
||||
data instance Catalog 1 = CatalogV1 { updated :: Time
|
||||
data instance Catalog 1 = CatalogV1 { updated :: UTCTime
|
||||
, self :: Rel
|
||||
, start :: Rel
|
||||
, pagination :: Pagination
|
||||
|
@ -67,20 +62,6 @@ deriving instance Show (Entry 1)
|
|||
deriving instance Generic (Catalog 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 Time 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 :: Time
|
||||
docsTime = Time $ unsafePerformIO getCurrentTime
|
||||
|
||||
|
||||
instance ToNode SubSection where
|
||||
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]
|
||||
|
||||
|
@ -92,7 +73,7 @@ instance ToNode (Entry 1) where
|
|||
<entry>
|
||||
<title>#{title}
|
||||
<id>#{identifier}
|
||||
<updated>#{iso8601 $ getTime updated}
|
||||
<updated>#{iso8601 updated}
|
||||
<content>#{content}
|
||||
^{either toNode toNode link}
|
||||
|]
|
||||
|
@ -102,7 +83,7 @@ instance ToNode (Catalog 1) where
|
|||
<feed xmlns="http://www.w3.org/2005/Atom" xmlns:opds="http://opds-spec.org/2010/catalog">
|
||||
<id>#{unRel self}
|
||||
<title>Give me a title
|
||||
<updated>#{iso8601 $ getTime updated}
|
||||
<updated>#{iso8601 updated}
|
||||
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="self" href="#{unRel self}">
|
||||
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="start" href="#{unRel start}">
|
||||
$maybe n <- (next pagination)
|
||||
|
@ -115,57 +96,30 @@ instance ToNode (Catalog 1) where
|
|||
|
||||
class Monad m => VersionedCatalog m (v :: Nat) where
|
||||
getChannels :: SafeUser -> m (Catalog v)
|
||||
getBooks :: Channel.ChannelID -> SafeUser -> m (Catalog v)
|
||||
|
||||
instance VersionedCatalog AppM 1 where
|
||||
getChannels = getChannelsV1
|
||||
getBooks = getBooksV1
|
||||
|
||||
relUrl :: Link -> Rel
|
||||
relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
|
||||
|
||||
getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
|
||||
getBooksV1 channelID SafeUser{username} = do
|
||||
updated <- Time <$> liftIO getCurrentTime
|
||||
let self = relUrl selfUrl
|
||||
start = relUrl startUrl
|
||||
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
|
||||
startUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
|
||||
pagination = Pagination Nothing Nothing
|
||||
entries <- map (toEntry updated) <$> runDB (Channel.channelBooks username channelID)
|
||||
pure CatalogV1{..}
|
||||
where
|
||||
toEntry updated Book{description,title,identifier=bookId} =
|
||||
let content = fromMaybe "no content" description
|
||||
identifier = pack . show $ bookId
|
||||
link = Right (Acquisition (relUrl (safeLink (Proxy @API.Books.BaseAPI) (Proxy @API.Books.GetBook) bookId)))
|
||||
in EntryV1{..}
|
||||
|
||||
getChannelsV1 :: SafeUser -> AppM (Catalog 1)
|
||||
getChannelsV1 SafeUser{username} = do
|
||||
updated <- Time <$> liftIO getCurrentTime
|
||||
let self = relUrl selfUrl
|
||||
-- I'm not sure if this safe link approach is really useable with this
|
||||
-- api hierarchy since I can't access the topmost api from here. Also
|
||||
-- authentication would bring a little bit of extra effort as well
|
||||
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
|
||||
start = self
|
||||
pagination = Pagination Nothing Nothing
|
||||
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
|
||||
pure CatalogV1{..}
|
||||
where
|
||||
fromChannel :: Time -> Channel.Channel -> Entry 1
|
||||
fromChannel updated Channel.Channel{..} =
|
||||
let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
|
||||
self = relUrl url
|
||||
in EntryV1 channel channel updated channel (Left $ SubSection self)
|
||||
getChannels SafeUser{username} = do
|
||||
updated <- liftIO getCurrentTime
|
||||
let self = Rel ("/api/current/" <> selfUrl)
|
||||
-- I'm not sure if this safe link approach is really useable with this
|
||||
-- api hierarchy since I can't access the topmost api from here. Also
|
||||
-- authentication would bring a little bit of extra effort as well
|
||||
selfUrl = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(RootCatalog 1))
|
||||
start = self
|
||||
pagination = Pagination Nothing Nothing
|
||||
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
|
||||
pure CatalogV1{..}
|
||||
where
|
||||
fromChannel :: UTCTime -> Channel.Channel -> Entry 1
|
||||
fromChannel updated Channel.Channel{..} =
|
||||
let url = pack . uriPath . linkURI $ safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
|
||||
self = Rel ("/api/current/" <> url)
|
||||
in EntryV1 channel channel updated channel (Left $ SubSection self)
|
||||
|
||||
type VersionedAPI (v :: Nat) = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI v
|
||||
|
||||
type CatalogContent = '[XML, OPDS]
|
||||
|
||||
type RootCatalog (v :: Nat) = "catalog" :> Get CatalogContent (Catalog v)
|
||||
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get CatalogContent (Catalog v)
|
||||
type RootCatalog (v :: Nat) = "catalog" :> Get '[XML] (Catalog v)
|
||||
type ChannelCatalog (v :: Nat) = "catalog" :> "channel" :> Capture "channel_id" Channel.ChannelID :> Get '[XML] (Catalog v)
|
||||
type BaseAPI (v :: Nat) = RootCatalog v
|
||||
:<|> ChannelCatalog v
|
||||
|
||||
|
@ -173,8 +127,6 @@ handler :: forall v. VersionedCatalog AppM v => ServerT (VersionedAPI v) AppM
|
|||
handler auth = catalogRoot :<|> catalogChannels
|
||||
where
|
||||
catalogChannels :: Channel.ChannelID -> AppM (Catalog v)
|
||||
-- Channel specific catalog returns tags inside the catalog
|
||||
catalogChannels identifier = flip requireLoggedIn auth (getBooks identifier)
|
||||
catalogChannels _ = throwM err403{errBody="Not implemented"}
|
||||
catalogRoot :: AppM (Catalog v)
|
||||
-- catalog root returns channels
|
||||
catalogRoot = flip requireLoggedIn auth getChannels
|
|
@ -1,47 +1,40 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language QuasiQuotes #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
{-# Language DeriveGeneric #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language TypeApplications #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language NamedFieldPuns #-}
|
||||
module API.Channels (API, handler, JsonChannel(..)) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Control.Monad.Logger
|
||||
import Data.Aeson
|
||||
import Data.Generics.Product
|
||||
import Database
|
||||
import Database.Channel
|
||||
import Servant
|
||||
import Servant.Auth as SA
|
||||
import qualified Servant.Docs as Docs
|
||||
import Server.Auth
|
||||
import Types
|
||||
import Servant
|
||||
import Types
|
||||
import ClassyPrelude
|
||||
import Server.Auth
|
||||
import Servant.Auth as SA
|
||||
import Control.Monad.Logger
|
||||
import Database
|
||||
import Database.Channel
|
||||
import Data.Aeson
|
||||
import Control.Lens
|
||||
import Data.Generics.Product
|
||||
|
||||
data JsonChannel = JsonChannel { channel :: Text
|
||||
data JsonChannel = JsonChannel { channel :: Text
|
||||
, visibility :: Visibility }
|
||||
deriving (Show, Generic)
|
||||
data UpdateChannel = UpdateChannel { identifier :: ChannelID
|
||||
, channel :: Text
|
||||
, channel :: Text
|
||||
, visibility :: Visibility }
|
||||
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 FromJSON JsonChannel
|
||||
instance ToJSON UpdateChannel
|
|
@ -1,44 +1,39 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language TypeApplications #-}
|
||||
{-# Language GeneralizedNewtypeDeriving #-}
|
||||
{-# Language NamedFieldPuns #-}
|
||||
module API.Users where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Catch (throwM)
|
||||
import Data.Aeson
|
||||
import Database (runDB)
|
||||
import Database.Schema
|
||||
import Database.User
|
||||
import Servant
|
||||
import Servant.Auth as SA
|
||||
import Servant.Auth.Server as SAS
|
||||
import qualified Servant.Docs as Docs
|
||||
import Server.Auth
|
||||
import Types
|
||||
import Web.FormUrlEncoded
|
||||
import Servant
|
||||
import ClassyPrelude
|
||||
import Types
|
||||
import Data.Aeson
|
||||
import Web.FormUrlEncoded
|
||||
import Database (runDB)
|
||||
import Database.User
|
||||
import Database.Schema
|
||||
import Server.Auth
|
||||
import Servant.Auth.Server as SAS
|
||||
import Servant.Auth as SA
|
||||
|
||||
|
||||
data RegisterForm = RegisterForm { username :: Username
|
||||
, email :: Email
|
||||
, password :: PlainPassword
|
||||
data RegisterForm = RegisterForm { username :: Username
|
||||
, email :: Email
|
||||
, password :: PlainPassword
|
||||
, passwordAgain :: PlainPassword }
|
||||
deriving (Generic, Show)
|
||||
|
||||
instance Docs.ToSample RegisterForm
|
||||
|
||||
data LoginStatus = LoginStatus ( Maybe SafeUser ) deriving Generic
|
||||
|
||||
data RegisterStatus = RegisterStatus deriving Generic
|
||||
|
||||
instance Docs.ToSample RegisterStatus
|
||||
|
||||
instance ToJSON LoginStatus
|
||||
instance FromJSON LoginStatus
|
||||
instance Docs.ToSample LoginStatus
|
||||
|
||||
instance FromJSON RegisterForm
|
||||
instance ToJSON RegisterForm
|
||||
|
@ -47,16 +42,20 @@ instance FromJSON RegisterStatus
|
|||
instance FromForm RegisterForm
|
||||
instance ToForm RegisterForm
|
||||
|
||||
|
||||
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> "login" :> Get '[JSON] LoginStatus
|
||||
:<|> "register" :> ReqBody '[JSON, FormUrlEncoded] RegisterForm :> Post '[JSON] RegisterStatus
|
||||
:<|> Auth '[SA.BasicAuth] SafeUser :> "token" :> Post '[JSON, PlainText] Token
|
||||
|
||||
handler :: ServerT API AppM
|
||||
handler = loginHandler :<|> registerHandler
|
||||
handler = loginHandler :<|> registerHandler :<|> newTokenHandler
|
||||
|
||||
newTokenHandler :: AuthResult SafeUser -> AppM Token
|
||||
newTokenHandler = requireLoggedIn $ \SafeUser{username} ->
|
||||
runDB (createToken username)
|
||||
|
||||
loginHandler :: AuthResult SafeUser -> AppM LoginStatus
|
||||
loginHandler (Authenticated u) = return (LoginStatus (Just u))
|
||||
loginHandler _ = return (LoginStatus Nothing)
|
||||
loginHandler _ = return (LoginStatus Nothing)
|
||||
|
||||
registerHandler :: RegisterForm -> AppM RegisterStatus
|
||||
registerHandler RegisterForm{..} =
|
|
@ -9,20 +9,15 @@ import Dhall (Interpret)
|
|||
data Pg = Pg { username :: Text
|
||||
, password :: Text
|
||||
, host :: Text
|
||||
, database :: Text
|
||||
, migrations :: Text }
|
||||
, database :: Text }
|
||||
deriving (Show, Generic)
|
||||
|
||||
data Store = Filestore { path :: Text }
|
||||
| IPFS { common :: Text }
|
||||
deriving (Show, Generic)
|
||||
newtype Store = Store { path :: Text } deriving (Show, Generic)
|
||||
|
||||
data Config = Config { database :: Pg
|
||||
, store :: Store
|
||||
, port :: Integer }
|
||||
, store :: Store }
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Interpret Pg
|
||||
instance Interpret Store
|
||||
instance Interpret Config
|
||||
|
|
@ -15,17 +15,15 @@ module Database
|
|||
, SeldaT )
|
||||
where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens (view)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Data.Generics.Product
|
||||
import Control.Lens (view)
|
||||
import Data.Pool (Pool, withResource)
|
||||
import Database.Selda (query, select, transaction)
|
||||
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
|
||||
import Database.Selda (query, select, transaction)
|
||||
import Database.Selda.Generic (gen, fromRel, fromRels, toRel)
|
||||
import ClassyPrelude
|
||||
|
||||
type DBLike r m = (MonadBaseControl IO m, MonadIO m, MonadReader r m, HasField "database" r r (Pool SeldaConnection) (Pool SeldaConnection), MonadMask m)
|
||||
type DBLike r m = (MonadIO m, MonadReader r m, MonadBaseControl IO m, MonadMask m, HasField' "database" r (Pool SeldaConnection))
|
||||
|
||||
runDB :: DBLike r m => SeldaT m a -> m a
|
||||
runDB q = do
|
|
@ -18,17 +18,18 @@ module Database.Book
|
|||
, BookID) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens (view)
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Data.Generics.Product
|
||||
import Database
|
||||
import Database.Channel (booksChannels, attachChannel, clearChannels)
|
||||
import Database.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
|
||||
import Database
|
||||
import Database.Selda
|
||||
import Database.Selda.Generic
|
||||
import Database.Tag (booksTags, attachTag, clearTags)
|
||||
|
||||
usersBooks :: (MonadSelda m, MonadIO m) => Username -> m [Book]
|
||||
import Control.Lens (view)
|
||||
import Data.Generics.Product
|
||||
|
||||
import Database.Tag (booksTags, attachTag, clearTags)
|
||||
import Database.Channel (booksChannels, attachChannel, clearChannels)
|
||||
|
||||
usersBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> m [Book]
|
||||
usersBooks username = fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -40,7 +41,7 @@ usersBooks username = fromRels <$> query q
|
|||
return book
|
||||
|
||||
|
||||
getBook :: (MonadSelda m, MonadIO m) => BookID -> Username -> m (Maybe Book)
|
||||
getBook :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> m (Maybe Book)
|
||||
getBook identifier owner = listToMaybe . fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -50,12 +51,12 @@ getBook identifier owner = listToMaybe . fromRels <$> query q
|
|||
return book
|
||||
|
||||
data InsertBook = InsertBook { contentType :: Text
|
||||
, title :: Text
|
||||
, title :: Maybe Text
|
||||
, description :: Maybe Text
|
||||
, owner :: Username }
|
||||
|
||||
-- Always inserts
|
||||
insertBook :: (MonadSelda m, MonadIO m) => InsertBook -> m (Maybe BookID)
|
||||
insertBook :: (MonadSelda m, MonadMask m, MonadIO m) => InsertBook -> m (Maybe BookID)
|
||||
insertBook InsertBook{..} = do
|
||||
mUserId <- query $ do
|
||||
userId :*: _ :*: username' :*: _ <- select (gen users)
|
||||
|
@ -67,14 +68,14 @@ insertBook InsertBook{..} = do
|
|||
|
||||
data UpdateBook = UpdateBook { identifier :: BookID
|
||||
, contentType :: Text
|
||||
, title :: Text
|
||||
, title :: Maybe Text
|
||||
, description :: Maybe Text
|
||||
, owner :: Username
|
||||
, tags :: [Text]
|
||||
, channels :: [Text] }
|
||||
deriving (Show, Generic)
|
||||
|
||||
bookExists :: (MonadSelda m, MonadIO m) => BookID -> m Bool
|
||||
bookExists :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m Bool
|
||||
bookExists identifier = not . null <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -82,7 +83,7 @@ bookExists identifier = not . null <$> query q
|
|||
restrict (bookId .== literal identifier)
|
||||
return bookId
|
||||
|
||||
isBookOwner :: (MonadSelda m, MonadIO m) => BookID -> Username -> m Bool
|
||||
isBookOwner :: (MonadSelda m, MonadIO m, MonadThrow m) => BookID -> Username -> m Bool
|
||||
isBookOwner identifier username = not . null <$> query (bookOwner' identifier username)
|
||||
|
||||
bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
|
||||
|
@ -94,7 +95,7 @@ bookOwner' identifier username = do
|
|||
restrict (bookId .== literal identifier)
|
||||
return (userId :*: bookId)
|
||||
|
||||
updateBook :: (MonadCatch m, MonadSelda m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
|
||||
updateBook :: (MonadSelda m, MonadMask m, MonadIO m) => UpdateBook -> m (Maybe UpdateBook)
|
||||
updateBook UpdateBook{..} = do
|
||||
clearTags identifier >> connectTags
|
||||
clearChannels identifier >> connectChannels
|
||||
|
@ -113,7 +114,7 @@ updateBook UpdateBook{..} = do
|
|||
predicate (bookId :*: _) = bookId .== literal identifier
|
||||
|
||||
|
||||
getUpdateBook :: (MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook)
|
||||
getUpdateBook :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> Username -> m (Maybe UpdateBook)
|
||||
getUpdateBook bookId username = do
|
||||
mBook <- getBook bookId username
|
||||
forM mBook $ \Book{..} -> do
|
||||
|
@ -121,7 +122,7 @@ getUpdateBook bookId username = do
|
|||
tags <- map (view (field @"tag")) <$> booksTags bookId
|
||||
return UpdateBook{owner=username,..}
|
||||
|
||||
setContent :: (MonadSelda m, MonadIO m) => BookID -> Username -> HashDigest -> m ()
|
||||
setContent :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> Username -> HashDigest -> m ()
|
||||
setContent identifier owner digest = do
|
||||
mOwner <- query (bookOwner' identifier owner)
|
||||
void $ forM (listToMaybe mOwner) $ \_ ->
|
|
@ -11,21 +11,19 @@ module Database.Channel
|
|||
, Visibility(..)
|
||||
, clearChannels
|
||||
, booksChannels
|
||||
, channelBooks
|
||||
, Channel(..)
|
||||
, ChannelID(..) )
|
||||
, ChannelID )
|
||||
where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Database
|
||||
import Database.Schema
|
||||
import Database
|
||||
import Database.Selda
|
||||
import Database.Selda.Generic
|
||||
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
getChannel :: (MonadSelda m, MonadIO m) => ChannelID -> m (Maybe Channel)
|
||||
getChannel :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m (Maybe Channel)
|
||||
getChannel identifier = listToMaybe . fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -33,10 +31,10 @@ getChannel identifier = listToMaybe . fromRels <$> query q
|
|||
restrict (channelId .== literal identifier)
|
||||
return ch
|
||||
|
||||
channelExists :: (MonadSelda m, MonadIO m) => ChannelID -> m Bool
|
||||
channelExists :: (MonadSelda m, MonadMask m, MonadIO m) => ChannelID -> m Bool
|
||||
channelExists identifier = not . null <$> getChannel identifier
|
||||
|
||||
isChannelOwner :: (MonadSelda m, MonadIO m) => ChannelID -> Username -> m Bool
|
||||
isChannelOwner :: (MonadSelda m, MonadIO m, MonadMask m) => ChannelID -> Username -> m Bool
|
||||
isChannelOwner identifier username = not . null <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -57,7 +55,7 @@ userChannels username = fromRels <$> query q
|
|||
restrict (username' .== literal username)
|
||||
return channel
|
||||
|
||||
updateChannelPrivacy :: (MonadIO m, MonadSelda m) => ChannelID -> Visibility -> m (Maybe Channel)
|
||||
updateChannelPrivacy :: (MonadMask m, MonadIO m, MonadSelda m) => ChannelID -> Visibility -> m (Maybe Channel)
|
||||
updateChannelPrivacy channelId visibility = do
|
||||
void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility])
|
||||
getChannel channelId
|
||||
|
@ -82,20 +80,7 @@ insertChannel username channel visibility = runMaybeT $ do
|
|||
restrict (user .== literal username)
|
||||
return userId
|
||||
|
||||
channelBooks :: (MonadSelda m, MonadIO m) => Username -> ChannelID -> m [Book]
|
||||
channelBooks username identifier = fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
channelId :*: bookId' <- select (gen bookChannels)
|
||||
channelId' :*: _ :*: owner :*: _ <- select (gen channels)
|
||||
userId :*: _ :*: username' :*: _ <- select (gen users)
|
||||
book@(bookId :*: _) <- select (gen books)
|
||||
restrict (username' .== literal username .&& owner .== userId)
|
||||
restrict (channelId .== literal identifier .&& channelId .== channelId')
|
||||
restrict (bookId .== bookId')
|
||||
return book
|
||||
|
||||
booksChannels :: (MonadSelda m, MonadIO m) => BookID -> m [Channel]
|
||||
booksChannels :: (MonadSelda m, MonadMask m, MonadIO m) => BookID -> m [Channel]
|
||||
booksChannels bookId = fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -105,7 +90,7 @@ booksChannels bookId = fromRels <$> query q
|
|||
restrict (bookId' .== literal bookId)
|
||||
return ch
|
||||
|
||||
attachChannel :: (MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
|
||||
attachChannel :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
|
||||
attachChannel username bookId channel = do
|
||||
mCh <- fromRels <$> query channelQ
|
||||
forM_ mCh $ \Channel{identifier} ->
|
||||
|
@ -124,5 +109,5 @@ attachChannel username bookId channel = do
|
|||
restrict (channel' .== literal channel)
|
||||
return ch
|
||||
|
||||
clearChannels :: (MonadIO m, MonadSelda m) => BookID -> m Int
|
||||
clearChannels :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int
|
||||
clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId)
|
|
@ -1,102 +1,102 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language DeriveGeneric #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language GeneralizedNewtypeDeriving #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
module Database.Schema where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Aeson
|
||||
import Database.Selda
|
||||
import Database.Selda.Backend
|
||||
import Database.Selda.Generic
|
||||
import qualified Servant.Docs as Docs
|
||||
import Servant (Capture)
|
||||
import Web.HttpApiData
|
||||
import ClassyPrelude
|
||||
import Database.Selda.Generic
|
||||
import Database.Selda
|
||||
import Database.Selda.Backend
|
||||
|
||||
import Data.Aeson
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
import Servant (MimeRender(..), PlainText)
|
||||
|
||||
-- | 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)
|
||||
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
|
||||
data NoPassword = NoPassword
|
||||
|
||||
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq, IsString)
|
||||
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
|
||||
|
||||
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")]
|
||||
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"
|
||||
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, Num)
|
||||
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord)
|
||||
|
||||
instance Docs.ToCapture (Capture "book_id" BookID) where
|
||||
toCapture _ = Docs.DocCapture "book_id" "The book id"
|
||||
|
||||
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON, Eq, Generic, Num)
|
||||
|
||||
instance Docs.ToCapture (Capture "channel_id" ChannelID) where
|
||||
toCapture _ = Docs.DocCapture "channel_id" "The channel id"
|
||||
newtype ChannelID = ChannelID {unChannelID :: Int} deriving (Show, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON)
|
||||
|
||||
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))
|
||||
|
||||
newtype Token = Token { unToken :: UUID } deriving (Show, ToJSON)
|
||||
|
||||
instance MimeRender PlainText Token where
|
||||
mimeRender _ = UUID.toLazyASCIIBytes . unToken
|
||||
|
||||
instance SqlType Token where
|
||||
mkLit = LCustom . LText . UUID.toText . unToken
|
||||
fromSql (SqlString x) = maybe (error "fromSql: Could not parse token") Token . UUID.fromText $ x
|
||||
fromSql _ = error "fromSql: Could not parse token"
|
||||
defaultValue = mkLit (Token UUID.nil)
|
||||
|
||||
data User pass = User { identifier :: UserID
|
||||
, email :: Email
|
||||
, username :: Username
|
||||
, role :: Role
|
||||
, password :: pass }
|
||||
, email :: Email
|
||||
, username :: Username
|
||||
, role :: Role
|
||||
, token :: Maybe Token
|
||||
, password :: pass
|
||||
}
|
||||
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)
|
||||
|
||||
instance ToJSON Role
|
||||
instance FromJSON Role
|
||||
|
@ -117,18 +117,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 :: Maybe 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
|
||||
|
@ -139,12 +139,12 @@ 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
|
||||
deriving (Show, Read, Generic, Eq)
|
||||
deriving (Show, Read, Generic)
|
||||
|
||||
instance ToJSON Visibility
|
||||
instance FromJSON Visibility
|
||||
|
@ -156,8 +156,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)
|
||||
|
||||
|
@ -173,12 +173,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
|
|
@ -12,14 +12,13 @@ module Database.Tag
|
|||
, Tag(..) ) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Database
|
||||
import Database.Schema
|
||||
import Database
|
||||
import Database.Selda
|
||||
import Database.Selda.Generic
|
||||
import Control.Monad.Trans.Maybe
|
||||
|
||||
upsertTag :: (MonadCatch m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag)
|
||||
upsertTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> Text -> m (Maybe Tag)
|
||||
upsertTag username tag = runMaybeT $ do
|
||||
userId <- MaybeT (listToMaybe <$> query userQ)
|
||||
void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)]
|
||||
|
@ -35,7 +34,7 @@ upsertTag username tag = runMaybeT $ do
|
|||
restrict (username' .== literal username)
|
||||
return userId
|
||||
|
||||
booksTags :: (MonadIO m, MonadSelda m) => BookID -> m [Tag]
|
||||
booksTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m [Tag]
|
||||
booksTags bookId = fromRels <$> query q
|
||||
where
|
||||
q = do
|
||||
|
@ -45,7 +44,7 @@ booksTags bookId = fromRels <$> query q
|
|||
restrict (bookId' .== literal bookId)
|
||||
return tag
|
||||
|
||||
attachTag :: (MonadCatch m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
|
||||
attachTag :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> BookID -> Text -> m ()
|
||||
attachTag username bookId tag = do
|
||||
maybeT <- upsertTag username tag
|
||||
forM_ maybeT $ \Tag{identifier} -> do
|
||||
|
@ -57,6 +56,6 @@ attachTag username bookId tag = do
|
|||
restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
|
||||
return tagId'
|
||||
|
||||
clearTags :: (MonadIO m, MonadSelda m) => BookID -> m Int
|
||||
clearTags :: (MonadMask m, MonadIO m, MonadSelda m) => BookID -> m Int
|
||||
clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId)
|
||||
|
|
@ -2,24 +2,33 @@
|
|||
{-# Language TypeApplications #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
module Database.User where
|
||||
{-# Language FlexibleContexts #-}
|
||||
module Database.User
|
||||
( Token
|
||||
, insertUser
|
||||
, getUser
|
||||
, validateUser
|
||||
, createToken
|
||||
, invalidateToken )
|
||||
where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens (view, over, _Just)
|
||||
import Control.Monad (mfilter)
|
||||
import Control.Monad.Catch (MonadMask)
|
||||
import Control.Monad.Logger
|
||||
import Crypto.KDF.BCrypt
|
||||
import Crypto.Random.Types (MonadRandom)
|
||||
import Data.Generics.Product
|
||||
import Database
|
||||
import Database.Schema
|
||||
import Database.Selda
|
||||
import Control.Lens (view, over, _Just)
|
||||
import Data.Generics.Product
|
||||
import Crypto.KDF.BCrypt
|
||||
import Crypto.Random.Types (MonadRandom)
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad (mfilter)
|
||||
import qualified Data.UUID.V4 as UUID
|
||||
|
||||
data UserExistsError = UserExistsError
|
||||
|
||||
|
||||
insertUser :: (MonadMask m, MonadLogger m, MonadIO m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
|
||||
|
||||
insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
|
||||
insertUser username email (PlainPassword password) =
|
||||
getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
|
||||
where
|
||||
|
@ -27,7 +36,7 @@ insertUser username email (PlainPassword password) =
|
|||
insertAs role = do
|
||||
lift $ $logInfo $ "Inserting new user as " <> pack (show role)
|
||||
let bytePass = encodeUtf8 password
|
||||
user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
|
||||
user <- User def email username role Nothing . HashedPassword <$> lift (hashPassword 12 bytePass)
|
||||
insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user)
|
||||
|
||||
adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
|
||||
|
@ -59,3 +68,21 @@ getUser' name = listToMaybe . fmap fromRel <$> query q
|
|||
u@(_ :*: _ :*: username :*: _ ) <- select (gen users)
|
||||
restrict (username .== literal name)
|
||||
return u
|
||||
|
||||
createToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m Token
|
||||
createToken username = do
|
||||
token <- Token <$> liftIO UUID.nextRandom
|
||||
void $ update (gen users) predicate (updateToken token)
|
||||
return token
|
||||
where
|
||||
_ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users)
|
||||
predicate user = user ! pUsername .== literal username
|
||||
updateToken token user= user `with` [pToken := literal (Just token)]
|
||||
|
||||
invalidateToken :: (MonadMask m, MonadIO m, MonadSelda m) => Username -> m ()
|
||||
invalidateToken username = do
|
||||
void $ update (gen users) predicate updateToken
|
||||
where
|
||||
_ :*: _ :*: pUsername :*: _ :*: pToken :*: _ = selectors (gen users)
|
||||
predicate user = user ! pUsername .== literal username
|
||||
updateToken user= user `with` [pToken := literal Nothing]
|
|
@ -5,7 +5,6 @@
|
|||
{-# Language FlexibleContexts #-}
|
||||
{-# Language TypeSynonymInstances #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language ScopedTypeVariables #-}
|
||||
module Datastore where
|
||||
|
||||
import ClassyPrelude
|
||||
|
@ -29,26 +28,26 @@ instance MonadDS AppM where
|
|||
get = getLocal
|
||||
|
||||
putLocal :: ( MonadIO m
|
||||
, HasField "config" r r config config
|
||||
, HasField "store" config config store store
|
||||
, HasType Text store
|
||||
, HasField' "config" r config
|
||||
, HasField' "store" config store
|
||||
, HasField' "path" store Text
|
||||
, MonadReader r m)
|
||||
=> ByteString -> m (Digest SHA256)
|
||||
putLocal bs = do
|
||||
store :: FilePath <- unpack <$> view (field @"config" . field @"store" . typed @Text)
|
||||
store <- unpack <$> view (field @"config" . field @"store" . field @"path")
|
||||
liftIO $ createDirectoryIfMissing True store
|
||||
let key = hashWith SHA256 bs
|
||||
writeFile (store </> show key) bs
|
||||
return key
|
||||
|
||||
getLocal :: ( MonadIO m
|
||||
, HasField "config" r r config config
|
||||
, HasField "store" config config store store
|
||||
, HasType Text store
|
||||
, HasField' "config" r config
|
||||
, HasField' "store" config store
|
||||
, HasField' "path" store Text
|
||||
, MonadReader r m)
|
||||
=> Digest SHA256 -> m (Maybe ByteString)
|
||||
getLocal key = do
|
||||
store <- unpack <$> view (field @"config" . field @"store" . typed @Text)
|
||||
store <- unpack <$> view (field @"config" . field @"store" . field @"path")
|
||||
liftIO $ createDirectoryIfMissing True store
|
||||
let file = store </> show key
|
||||
exists <- liftIO $ doesFileExist file
|
|
@ -3,18 +3,19 @@
|
|||
{-# Language FlexibleContexts #-}
|
||||
module Devel.Main where
|
||||
|
||||
import Prelude
|
||||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Main (withApp, defaultMain)
|
||||
import Control.Concurrent
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Database
|
||||
import Database.Schema
|
||||
import Database.Selda (tryCreateTable)
|
||||
import Dhall (input, auto)
|
||||
import Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
|
||||
import GHC.Word (Word32)
|
||||
import Main (withApp, defaultMain)
|
||||
import Prelude
|
||||
import Dhall (input, auto)
|
||||
|
||||
import Database.Schema
|
||||
import Database.Selda (tryCreateTable)
|
||||
import Database
|
||||
|
||||
update :: IO ()
|
||||
update = do
|
||||
|
@ -36,7 +37,7 @@ update = do
|
|||
|
||||
develMain :: IO ()
|
||||
develMain = do
|
||||
conf <- input auto "../config/devel.dhall"
|
||||
conf <- input auto "./config/devel.dhall"
|
||||
withApp conf $ \app -> do
|
||||
void $ runReaderT (runDB migrate) app
|
||||
defaultMain app
|
|
@ -0,0 +1,38 @@
|
|||
{-# Language OverloadedStrings #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language TypeApplications #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
module Main where
|
||||
|
||||
import Server (server)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Types
|
||||
import Configuration
|
||||
import Dhall (input, auto)
|
||||
import ClassyPrelude
|
||||
import Control.Lens (view)
|
||||
import Data.Generics.Product
|
||||
import Data.Pool (createPool)
|
||||
import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
|
||||
import Servant.Auth.Server (generateKey)
|
||||
|
||||
defaultMain :: App -> IO ()
|
||||
defaultMain = run 8080 . server
|
||||
|
||||
withApp :: Config -> (App -> IO ()) -> IO ()
|
||||
withApp config f = do
|
||||
let pgHost = view (field @"database" . field @"host") config
|
||||
pgPort = 5432
|
||||
pgDatabase = view (field @"database" . field @"database") config
|
||||
pgUsername = Just (view (field @"database" . field @"username") config)
|
||||
pgPassword = Just (view (field @"database" . field @"password") config)
|
||||
database <- createPool (pgOpen (PGConnectInfo{..})) seldaClose 10 2 5
|
||||
jwk <- generateKey
|
||||
f App{..}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
c <- input auto "./config/config.dhall"
|
||||
withApp c defaultMain
|
|
@ -1,11 +1,9 @@
|
|||
{-# Language OverloadedStrings #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
{-# Language TypeApplications #-}
|
||||
module Servant.XML
|
||||
( ToNode(..)
|
||||
, XML
|
||||
, OPDS
|
||||
, Text.Hamlet.XML.xml
|
||||
, iso8601 )
|
||||
where
|
||||
|
@ -18,22 +16,14 @@ import Network.HTTP.Media.MediaType
|
|||
|
||||
data XML
|
||||
|
||||
data OPDS
|
||||
|
||||
instance (ToNode a) => MimeRender XML a where
|
||||
mimeRender _ a =
|
||||
let [NodeElement root] = toNode a
|
||||
in renderLBS def (Document (Prologue [] Nothing []) root [])
|
||||
|
||||
instance (ToNode a) => MimeRender OPDS a where
|
||||
mimeRender _ a = mimeRender (Proxy @XML) a
|
||||
|
||||
instance Accept XML where
|
||||
contentType _ = "application" // "xml" /: ("charset", "utf-8")
|
||||
|
||||
instance Accept OPDS where
|
||||
contentType _ = "application" // "atom+xml" /: ("charset", "utf-8") /: ("profile", "opds-catalog")
|
||||
|
||||
iso8601 :: UTCTime -> Text
|
||||
iso8601 = pack . formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ"
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language MultiParamTypeClasses #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language QuasiQuotes #-}
|
||||
{-# Language RecordWildCards #-}
|
||||
{-# Language DeriveGeneric #-}
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language TypeApplications #-}
|
||||
module Server where
|
||||
|
||||
import qualified API as API
|
||||
import Server.Auth (authCheck)
|
||||
import Servant
|
||||
import Types
|
||||
import ClassyPrelude hiding (Handler)
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Except
|
||||
import Servant.Auth.Server as SAS
|
||||
import Control.Lens
|
||||
import Data.Generics.Product
|
||||
|
||||
type API = API.API :<|> "static" :> Raw
|
||||
|
||||
|
||||
server :: App -> Application
|
||||
server app = serveWithContext api cfg (enter server' API.handler :<|> serveDirectoryFileServer "static")
|
||||
where
|
||||
myKey = view (field @"jwk") app
|
||||
jwtCfg = defaultJWTSettings myKey
|
||||
authCfg = authCheck app
|
||||
cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
|
||||
cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
|
||||
server' :: AppM :~> Servant.Handler
|
||||
server' = NT (Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log"))
|
||||
api :: Proxy API
|
||||
api = Proxy
|
|
@ -1,45 +1,42 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# Language DataKinds #-}
|
||||
{-# Language TypeFamilies #-}
|
||||
{-# Language OverloadedStrings #-}
|
||||
{-# Language NoImplicitPrelude #-}
|
||||
{-# Language TypeOperators #-}
|
||||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language TypeApplications #-}
|
||||
{-# Language TemplateHaskell #-}
|
||||
{-# Language FlexibleContexts #-}
|
||||
module Server.Auth
|
||||
( SafeUser(..)
|
||||
, authCheck
|
||||
, AuthResult(..)
|
||||
, TokenCheck
|
||||
, requireLoggedIn)
|
||||
where
|
||||
|
||||
import ClassyPrelude
|
||||
import Control.Lens (view)
|
||||
import Control.Monad.Catch (MonadThrow, throwM)
|
||||
import Control.Monad.Logger
|
||||
import Data.Aeson
|
||||
import Data.Generics.Product
|
||||
import Database
|
||||
import Database.Schema
|
||||
import Database.User
|
||||
import Servant (err401)
|
||||
import Servant.Auth.Server as SAS
|
||||
import qualified Servant.Docs as Docs
|
||||
import Types
|
||||
import ClassyPrelude
|
||||
import Servant.Auth.Server as SAS
|
||||
import Data.Aeson
|
||||
import Database.Schema
|
||||
import Database.User
|
||||
import Database
|
||||
import Types
|
||||
import Control.Lens (view)
|
||||
import Data.Generics.Product
|
||||
import Servant (err401)
|
||||
import Control.Monad.Logger
|
||||
|
||||
-- generic-lens can convert similar types to this
|
||||
-- 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.
|
||||
--
|
||||
-- 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
|
||||
, role :: Role }
|
||||
, role :: Role }
|
||||
deriving (Show, Generic)
|
||||
|
||||
instance Docs.ToSample SafeUser where
|
||||
toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )]
|
||||
|
||||
instance ToJSON SafeUser where
|
||||
instance FromJSON SafeUser where
|
||||
instance ToJWT SafeUser where
|
||||
|
@ -58,6 +55,8 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
|
|||
password' = PlainPassword $ decodeUtf8 password
|
||||
authenticated = SAS.Authenticated . view (super @SafeUser)
|
||||
|
||||
requireLoggedIn :: (MonadThrow m, MonadLogger m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
|
||||
requireLoggedIn :: (MonadLogger m, MonadThrow m, Monad m) => (SafeUser -> m a) -> AuthResult SafeUser -> m a
|
||||
requireLoggedIn f (Authenticated user) = f user
|
||||
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401
|
||||
|
||||
data TokenCheck
|
|
@ -1,8 +0,0 @@
|
|||
\(conf : ./config/Configuration.dhall)
|
||||
->
|
||||
''
|
||||
flyway.locations=filesystem:${conf.database.migrations}/
|
||||
flyway.url=jdbc:postgresql://${conf.database.host}/${conf.database.database}
|
||||
flyway.user=${conf.database.username}
|
||||
flyway.password=${conf.database.password}
|
||||
''
|
Loading…
Reference in New Issue