Compare commits
No commits in common. "master" and "frontend" have entirely different histories.
@ -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
|
|
@ -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
|
||||||
|
@ -1,2 +0,0 @@
|
|||||||
**DEPRECATED**
|
|
||||||
[![Build Status](https://travis-ci.org/MasseR/ebook-manager.svg?branch=master)](https://travis-ci.org/MasseR/ebook-manager)
|
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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,9 +76,9 @@ 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
|
||||||
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]
|
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]
|
||||||
@ -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
|
||||||
|
@ -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]
|
||||||
|
@ -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{..} =
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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
|
||||||
|
@ -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"
|
, password = "password"
|
||||||
, host = "hostname"
|
, host = "hostname"
|
||||||
, database = "ebook"
|
, database = "ebook"
|
||||||
, migrations = "./migrations"
|
|
||||||
}
|
}
|
||||||
store = { path = "/tmp/store" }
|
|
||||||
}
|
}
|
||||||
|
@ -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
|
|
||||||
|
@ -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
|
||||||
|
@ -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
Block a user