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

Compare commits

base: MasseR:master
Branches Tags
MasseR:master
MasseR:frontend
MasseR:sandbox/MasseR/28-separate-lib
MasseR:sandbox/MasseR/18-tokens
MasseR:sandbox/MasseR/20-update-channels
MasseR:sandbox/MasseR/13-channel-visibility
MasseR:v0.1.0.0
..
compare: MasseR:frontend
Branches Tags
MasseR:master
MasseR:frontend
MasseR:sandbox/MasseR/28-separate-lib
MasseR:sandbox/MasseR/18-tokens
MasseR:sandbox/MasseR/20-update-channels
MasseR:sandbox/MasseR/13-channel-visibility
MasseR:v0.1.0.0

No commits in common. "master" and "frontend" have entirely different histories.
master ... frontend

19 changed files with 127 additions and 426 deletions
Show Stats Expand all files Collapse all files

233
.stylish-haskell.yaml
View File

@ -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

4
.travis.yml
View File

@ -8,5 +8,5 @@ before_script:
- mkdir -p ~/.config/nixpkgs - mkdir -p ~/.config/nixpkgs
script: 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 ./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" -A ghc.backend -A 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 - nix-build ./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" -A ghcjs.frontend

2
README.md
View File

@ -1,2 +0,0 @@
**DEPRECATED**
[![Build Status](https://travis-ci.org/MasseR/ebook-manager.svg?branch=master)](https://travis-ci.org/MasseR/ebook-manager)

20
backend/backend.cabal
View File

@ -17,7 +17,6 @@ cabal-version: >=1.10
executable backend executable backend
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
other-modules: Devel.Main other-modules: Devel.Main
, API , API
, API.Books , API.Books
@ -95,30 +94,25 @@ test-suite spec
main-is: Spec.hs main-is: Spec.hs
hs-source-dirs: src hs-source-dirs: src
build-depends: base >=4.10 build-depends: base >=4.10
, exceptions
, monad-control
, common
, aeson , aeson
, asn1-data , asn1-data
, asn1-types , asn1-types
, bytestring , bytestring
, classy-prelude , classy-prelude
, common
, cryptonite , cryptonite
, dhall , dhall
, directory , directory
, exceptions
, foreign-store , foreign-store
, generic-lens , generic-lens
, genvalidity-hspec
, genvalidity-hspec-aeson
, genvalidity-property
, genvalidity-text
, hspec
, http-api-data , http-api-data
, http-media , http-media
, jose , jose
, lens , lens
, lucid , lucid
, memory , memory
, monad-control
, monad-logger , monad-logger
, mtl , mtl
, pandoc , pandoc
@ -130,21 +124,25 @@ test-suite spec
, selda-postgresql , selda-postgresql
, servant , servant
, servant-auth , servant-auth
, servant-auth-docs
, servant-auth-server , servant-auth-server
, servant-docs , servant-docs
, servant-auth-docs
, servant-lucid , servant-lucid
, servant-multipart , servant-multipart
, servant-server , servant-server
, text , text
, transformers , transformers
, validity
, wai , wai
, warp , warp
, x509 , x509
, x509-store , x509-store
, xml-conduit , xml-conduit
, xml-hamlet , xml-hamlet
, validity
, genvalidity-hspec
, genvalidity-property
, genvalidity-text
, hspec
default-extensions: DeriveGeneric default-extensions: DeriveGeneric
, NoImplicitPrelude , NoImplicitPrelude
, OverloadedStrings , OverloadedStrings

20
backend/src/API.hs
View File

@ -1,21 +1,31 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module API (API, handler) where module API (API, handler) where
import Servant import Servant
import Servant.HTML.Lucid (HTML)
import Types import Types
import View
import qualified API.Books as Books import qualified API.Books as Books
import qualified API.Catalogue as Catalogue import qualified API.Catalogue as Catalogue
import qualified API.Channels as Channels import qualified API.Channels as Channels
import qualified API.Users as Users import qualified API.Users as Users
type API = "api" :> Users.API data Index = Index
type API = Users.API
:<|> "api" :> "current" :> Channels.API :<|> "api" :> "current" :> Channels.API
:<|> "api" :> "current" :> Books.API :<|> "api" :> "current" :> Books.API
:<|> "api" :> "1" :> Catalogue.VersionedAPI 1 :<|> "api" :> "1" :> Catalogue.VersionedAPI 1
@ -28,3 +38,11 @@ handler = Users.handler
:<|> Catalogue.handler :<|> Catalogue.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

4
backend/src/API/Books.hs
View File

@ -17,7 +17,7 @@ module API.Books where
import ClassyPrelude import ClassyPrelude
import Control.Lens import Control.Lens
import Control.Monad.Catch (throwM) import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Crypto.Hash (digestFromByteString) import Crypto.Hash (digestFromByteString)
import Data.Aeson import Data.Aeson
@ -63,6 +63,8 @@ instance FromJSON PostBook
type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI type API = Auth '[SA.BasicAuth, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "book_id" BookID) where
toCapture _ = Docs.DocCapture "book_id" "The book id"
type BaseAPI = "books" :> Get '[JSON] [JsonBook] type BaseAPI = "books" :> Get '[JSON] [JsonBook]
:<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook :<|> "books" :> ReqBody '[JSON] PostBook :> Post '[JSON] JsonBook

23
backend/src/API/Catalogue.hs
View File

@ -17,7 +17,7 @@
module API.Catalogue (VersionedAPI, handler) where module API.Catalogue (VersionedAPI, handler) where
import qualified API.Books import qualified API.Books
import ClassyPrelude hiding (link) import ClassyPrelude
import Database import Database
import Database.Book (Book(..)) import Database.Book (Book(..))
import qualified Database.Channel as Channel import qualified Database.Channel as Channel
@ -46,16 +46,15 @@ data Pagination = Pagination { previous :: Maybe Rel
newtype SubSection = SubSection Rel deriving (Show) newtype SubSection = SubSection Rel deriving (Show)
newtype Acquisition = Acquisition Rel deriving (Show) newtype Acquisition = Acquisition Rel deriving (Show)
newtype Time = Time { getTime :: UTCTime } deriving Show
data instance Entry 1 = EntryV1 { title :: Text data instance Entry 1 = EntryV1 { title :: Text
, identifier :: Text , identifier :: Text
, updated :: Time , updated :: UTCTime
, content :: Text , content :: Text
, link :: Either SubSection Acquisition , link :: Either SubSection Acquisition
} }
data instance Catalog 1 = CatalogV1 { updated :: Time data instance Catalog 1 = CatalogV1 { updated :: UTCTime
, self :: Rel , self :: Rel
, start :: Rel , start :: Rel
, pagination :: Pagination , pagination :: Pagination
@ -69,7 +68,7 @@ deriving instance Generic (Entry 1)
instance Docs.ToSample (Entry 1) where instance Docs.ToSample (Entry 1) where
toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))] toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))]
instance Docs.ToSample Time where instance Docs.ToSample UTCTime where
toSamples _ = [("time", docsTime)] toSamples _ = [("time", docsTime)]
instance Docs.ToSample Rel where instance Docs.ToSample Rel where
toSamples _ = [("Relative link", Rel "next")] toSamples _ = [("Relative link", Rel "next")]
@ -77,8 +76,8 @@ instance Docs.ToSample Pagination
instance Docs.ToSample (Catalog 1) -- where instance Docs.ToSample (Catalog 1) -- where
-- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])] -- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])]
docsTime :: Time docsTime :: UTCTime
docsTime = Time $ unsafePerformIO getCurrentTime docsTime = unsafePerformIO getCurrentTime
instance ToNode SubSection where instance ToNode SubSection where
@ -92,7 +91,7 @@ instance ToNode (Entry 1) where
<entry> <entry>
<title>#{title} <title>#{title}
<id>#{identifier} <id>#{identifier}
<updated>#{iso8601 $ getTime updated} <updated>#{iso8601 updated}
<content>#{content} <content>#{content}
^{either toNode toNode link} ^{either toNode toNode link}
|] |]
@ -102,7 +101,7 @@ instance ToNode (Catalog 1) where
<feed xmlns="http://www.w3.org/2005/Atom" xmlns:opds="http://opds-spec.org/2010/catalog"> <feed xmlns="http://www.w3.org/2005/Atom" xmlns:opds="http://opds-spec.org/2010/catalog">
<id>#{unRel self} <id>#{unRel self}
<title>Give me a title <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="self" href="#{unRel self}">
<link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="start" href="#{unRel start}"> <link type="application/atom+xml;profile=opds-catalog;kind=navigation" rel="start" href="#{unRel start}">
$maybe n <- (next pagination) $maybe n <- (next pagination)
@ -126,7 +125,7 @@ relUrl x = Rel ("/api/current/" <> (pack . uriPath . linkURI $ x))
getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1) getBooksV1 :: Channel.ChannelID -> SafeUser -> AppM (Catalog 1)
getBooksV1 channelID SafeUser{username} = do getBooksV1 channelID SafeUser{username} = do
updated <- Time <$> liftIO getCurrentTime updated <- liftIO getCurrentTime
let self = relUrl selfUrl let self = relUrl selfUrl
start = relUrl startUrl start = relUrl startUrl
selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID selfUrl = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) channelID
@ -143,7 +142,7 @@ getBooksV1 channelID SafeUser{username} = do
getChannelsV1 :: SafeUser -> AppM (Catalog 1) getChannelsV1 :: SafeUser -> AppM (Catalog 1)
getChannelsV1 SafeUser{username} = do getChannelsV1 SafeUser{username} = do
updated <- Time <$> liftIO getCurrentTime updated <- liftIO getCurrentTime
let self = relUrl selfUrl let self = relUrl selfUrl
-- I'm not sure if this safe link approach is really useable with this -- 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 -- api hierarchy since I can't access the topmost api from here. Also
@ -154,7 +153,7 @@ getChannelsV1 SafeUser{username} = do
entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username) entries <- map (fromChannel updated) <$> runDB (Channel.userChannels username)
pure CatalogV1{..} pure CatalogV1{..}
where where
fromChannel :: Time -> Channel.Channel -> Entry 1 fromChannel :: UTCTime -> Channel.Channel -> Entry 1
fromChannel updated Channel.Channel{..} = fromChannel updated Channel.Channel{..} =
let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier let url = safeLink (Proxy @(BaseAPI 1)) (Proxy @(ChannelCatalog 1)) identifier
self = relUrl url self = relUrl url

5
backend/src/API/Channels.hs
View File

@ -16,7 +16,7 @@ module API.Channels (API, handler, JsonChannel(..)) where
import ClassyPrelude import ClassyPrelude
import Control.Lens import Control.Lens
import Control.Monad.Catch (throwM) import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import Data.Generics.Product import Data.Generics.Product
@ -49,6 +49,9 @@ instance FromJSON UpdateChannel
type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI type API = Auth '[SA.BasicAuth, SA.Cookie, SA.JWT] SafeUser :> BaseAPI
instance Docs.ToCapture (Capture "channel_id" ChannelID) where
toCapture _ = Docs.DocCapture "channel_id" "The channel id"
type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel type BaseAPI = "channels" :> ReqBody '[JSON] JsonChannel :> Post '[JSON] UpdateChannel
:<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel :<|> "channels" :> Capture "channel_id" ChannelID :> ReqBody '[JSON] UpdateChannel :> Put '[JSON] UpdateChannel
:<|> "channels" :> Get '[JSON] [JsonChannel] :<|> "channels" :> Get '[JSON] [JsonChannel]

30
backend/src/API/Users.hs
View File

@ -1,30 +1,30 @@
{-# LANGUAGE DataKinds #-} {-# Language DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# Language TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# Language OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-} {-# Language NoImplicitPrelude #-}
{-# LANGUAGE TypeApplications #-} {-# Language TypeOperators #-}
{-# LANGUAGE TypeFamilies #-} {-# Language DuplicateRecordFields #-}
{-# LANGUAGE TypeOperators #-} {-# Language TypeApplications #-}
module API.Users where module API.Users where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Catch (throwM) import Control.Monad.Catch (throwM, MonadThrow)
import Data.Aeson import Data.Aeson
import Database (runDB) import Database (runDB)
import Database.Schema import Database.Schema
import Database.User import Database.User
import Servant import Servant
import Servant.Auth as SA import Servant.Auth as SA
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs import qualified Servant.Docs as Docs
import Server.Auth import Server.Auth
import Types import Types
import Web.FormUrlEncoded import Web.FormUrlEncoded
data RegisterForm = RegisterForm { username :: Username data RegisterForm = RegisterForm { username :: Username
, email :: Email , email :: Email
, password :: PlainPassword , password :: PlainPassword
, passwordAgain :: PlainPassword } , passwordAgain :: PlainPassword }
deriving (Generic, Show) deriving (Generic, Show)
@ -56,7 +56,7 @@ handler = loginHandler :<|> registerHandler
loginHandler :: AuthResult SafeUser -> AppM LoginStatus loginHandler :: AuthResult SafeUser -> AppM LoginStatus
loginHandler (Authenticated u) = return (LoginStatus (Just u)) loginHandler (Authenticated u) = return (LoginStatus (Just u))
loginHandler _ = return (LoginStatus Nothing) loginHandler _ = return (LoginStatus Nothing)
registerHandler :: RegisterForm -> AppM RegisterStatus registerHandler :: RegisterForm -> AppM RegisterStatus
registerHandler RegisterForm{..} = registerHandler RegisterForm{..} =

6
backend/src/Configuration.hs
View File

@ -9,8 +9,7 @@ import Dhall (Interpret)
data Pg = Pg { username :: Text data Pg = Pg { username :: Text
, password :: Text , password :: Text
, host :: Text , host :: Text
, database :: Text , database :: Text }
, migrations :: Text }
deriving (Show, Generic) deriving (Show, Generic)
data Store = Filestore { path :: Text } data Store = Filestore { path :: Text }
@ -18,8 +17,7 @@ data Store = Filestore { path :: Text }
deriving (Show, Generic) deriving (Show, Generic)
data Config = Config { database :: Pg data Config = Config { database :: Pg
, store :: Store , store :: Store }
, port :: Integer }
deriving (Show, Generic) deriving (Show, Generic)
instance Interpret Pg instance Interpret Pg

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

@ -3,9 +3,6 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Schema where module Database.Schema where
import ClassyPrelude import ClassyPrelude
@ -14,7 +11,6 @@ import Database.Selda
import Database.Selda.Backend import Database.Selda.Backend
import Database.Selda.Generic import Database.Selda.Generic
import qualified Servant.Docs as Docs import qualified Servant.Docs as Docs
import Servant (Capture)
import Web.HttpApiData import Web.HttpApiData
-- | User type -- | User type
@ -57,14 +53,8 @@ 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, ToHttpApiData, Generic, Num)
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) 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 TagID = TagID {unTagID :: Int} deriving (Show) newtype TagID = TagID {unTagID :: Int} deriving (Show)
instance SqlType UserID where instance SqlType UserID where

41
backend/src/Main.hs
View File

@ -1,27 +1,25 @@
{-# LANGUAGE DataKinds #-} {-# Language OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# Language RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# Language DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-} {-# Language TypeApplications #-}
{-# LANGUAGE RecordWildCards #-} {-# Language DataKinds #-}
{-# LANGUAGE TypeApplications #-} {-# Language NoImplicitPrelude #-}
module Main where module Main where
import ClassyPrelude import Server (server)
import Configuration import Network.Wai.Handler.Warp (run)
import Control.Lens (view, to) import Types
import Data.Generics.Product import Configuration
import Data.Pool (createPool) import Dhall (input, auto)
import Database.Selda.PostgreSQL (PGConnectInfo (..), pgOpen, import ClassyPrelude
seldaClose) import Control.Lens (view)
import Dhall (auto, input) import Data.Generics.Product
import Network.Wai.Handler.Warp (run) import Data.Pool (createPool)
import Servant.Auth.Server (generateKey) import Database.Selda.PostgreSQL (PGConnectInfo(..), pgOpen, seldaClose)
import Server (server) import Servant.Auth.Server (generateKey)
import Types
import System.Environment (getEnvironment)
defaultMain :: App -> IO () defaultMain :: App -> IO ()
defaultMain app = run (view (field @"config" . field @"port" . to fromIntegral) app) $ server app defaultMain = run 8080 . server
withApp :: Config -> (App -> IO ()) -> IO () withApp :: Config -> (App -> IO ()) -> IO ()
withApp config f = do withApp config f = do
@ -37,6 +35,5 @@ withApp config f = do
main :: IO () main :: IO ()
main = do main = do
path <- fmap pack . lookup "CONF" <$> getEnvironment c <- input auto "./config/config.dhall"
c <- input auto (fromMaybe "./config/config.dhall" path)
withApp c defaultMain withApp c defaultMain

16
backend/src/Server.hs
View File

@ -1,15 +1,19 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
module Server where module Server where
import qualified API import qualified API as API
import ClassyPrelude hiding (Handler) import ClassyPrelude hiding (Handler)
import Control.Lens import Control.Lens
import Control.Monad.Except import Control.Monad.Except
@ -20,16 +24,18 @@ import Servant.Auth.Docs ()
import Servant.Auth.Server as SAS import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs import qualified Servant.Docs as Docs
import Servant.HTML.Lucid (HTML) import Servant.HTML.Lucid (HTML)
import Server.Auth (SafeUser, authCheck) import Server.Auth (SafeUser)
import Server.Auth (authCheck)
import Types import Types
type API = API.API type API = API.API
:<|> "api" :> "help" :> Get '[PlainText, HTML] String :<|> "help" :> Get '[PlainText, HTML] String
:<|> "static" :> Raw
type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings] type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
server :: App -> Application server :: App -> Application
server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs) server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs :<|> serveDirectoryFileServer "static")
where where
apiDocs :: Docs.API apiDocs :: Docs.API
apiDocs = Docs.docs (Proxy @API.API) apiDocs = Docs.docs (Proxy @API.API)
@ -40,6 +46,6 @@ server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API)
cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure} cookieSettings = SAS.defaultCookieSettings{cookieIsSecure=SAS.NotSecure}
cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext cfg = jwtCfg :. cookieSettings :. authCfg :. EmptyContext
server' :: AppM a -> Servant.Handler a server' :: AppM a -> Servant.Handler a
server' = Handler . ExceptT . try . (`runReaderT` app) . runFileLoggingT "logs/server.log" server' = Handler . ExceptT . try . (`runReaderT` app) . (runFileLoggingT "logs/server.log")
api :: Proxy API api :: Proxy API
api = Proxy api = Proxy

27
backend/src/Spec.hs
View File

@ -1,16 +1,15 @@
{-# LANGUAGE TypeApplications #-} {-# Language TypeApplications #-}
module Main where module Main where
import API.Books import API.Books
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.Char (isPrint) import Data.Char (isPrint)
import Data.GenValidity.Text () import Data.GenValidity.Text ()
import qualified Data.Text as T import qualified Data.Text as T
import Database.Schema import Database.Schema
import Prelude import Prelude
import Test.Hspec import Test.Hspec
import Test.Validity import Test.Validity
import Test.Validity.Aeson
instance GenUnchecked PlainPassword instance GenUnchecked PlainPassword
instance GenValid PlainPassword instance GenValid PlainPassword
@ -52,15 +51,15 @@ instance Validity PostBook
spec :: Spec spec :: Spec
spec = do spec = do
describe "JSON encoding" $ do describe "JSON encoding" $ do
jsonSpecOnValid @PlainPassword it "Works for PlainPassword" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @PlainPassword) A.decode
jsonSpecOnValid @Email it "Works for Email" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Email) A.decode
jsonSpecOnValid @Username it "Username" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Username) A.decode
jsonSpecOnValid @BookID it "Works for BookID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @BookID) A.decode
jsonSpecOnValid @ChannelID it "Works for ChannelID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @ChannelID) A.decode
jsonSpecOnValid @Role it "Works for Role" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Role) A.decode
jsonSpecOnValid @Visibility it "Works for Visibility" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Visibility) A.decode
jsonSpecOnValid @JsonBook it "Works for JsonBook" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @JsonBook) A.decode
jsonSpecOnValid @PostBook it "Works for PostBook" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @PostBook) A.decode
main :: IO () main :: IO ()
main = hspec spec main = hspec spec

8
config/Configuration.dhall
View File

@ -1,8 +0,0 @@
{ database : { username : Text
, password : Text
, host : Text
, database : Text
, migrations : Text }
, store : < Filestore : { path : Text } | IPFS : { common : Text } >
, port : Integer
}

2
config/config.dhall.sample
View File

@ -4,7 +4,5 @@
, password = "password" , password = "password"
, host = "hostname" , host = "hostname"
, database = "ebook" , database = "ebook"
, migrations = "./migrations"
} }
store = { path = "/tmp/store" }
} }

8
frontend/frontend.cabal
View File

@ -20,13 +20,9 @@ executable frontend
-- other-modules: -- other-modules:
-- other-extensions: -- other-extensions:
build-depends: base >=4.11 && <4.12 build-depends: base >=4.11 && <4.12
, common
, generic-lens
, jsaddle-warp
, lens
, miso , miso
, jsaddle-warp
, mtl , mtl
, servant , common
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall

84
frontend/src/Main.hs
View File

@ -1,93 +1,41 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
module Main where module Main where
import Control.Lens (over, set)
import Control.Monad.Trans (liftIO) import Control.Monad.Trans (liftIO)
import Data.Generics.Product
import GHC.Generics (Generic)
import Language.Javascript.JSaddle.Warp import Language.Javascript.JSaddle.Warp
import Miso hiding (set) import Miso
import Miso.String 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 data Action = Add
| Subtract | Subtract
| SayHello | SayHello
| HandleURI URI
| ChangeURI URI
| NoOp | NoOp
data Model = Model { counter :: Int newtype Model = Model Int deriving (Eq, Num, ToMisoString)
, uri :: URI }
deriving (Eq, Generic)
updateModel :: Model -> Action -> Effect Action Model updateModel :: Action -> Model -> Effect Action Model
updateModel m = \case updateModel Add m = noEff (m + 1)
Add -> noEff (over (field @"counter") (+1) m) updateModel Subtract m = noEff (m - 1)
Subtract -> noEff (over (field @"counter") (\x -> x - 1) m) updateModel SayHello m = m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
SayHello -> m <# (liftIO (putStrLn "Hello world") >> pure NoOp) updateModel NoOp m = noEff m
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 Action
viewModel model = view viewModel x =
where div_ [] [ button_ [ onClick Add ] [ text "+" ]
view = either (const the404) id $ runRoute @API Proxy handlers uri model , text (ms x)
handlers = home :<|> login :<|> register , button_ [ onClick Subtract ] [ text "-" ]
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 :: IO ()
main = run 8081 $ do main = run 8081 $ startApp App{..}
model <- mkModel
startApp App{..}
where where
mkModel = Model <$> pure 0 <*> getCurrentURI model = Model 0
initialAction = SayHello initialAction = SayHello
update = flip updateModel update = updateModel
view = viewModel view = viewModel
subs = [ uriSub HandleURI ] subs = []
events = defaultEvents events = defaultEvents
mountPoint = Nothing mountPoint = Nothing

8
to-flyway.dhall
View File

@ -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}
''