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

Compare commits

base: 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
..
compare: MasseR:a7f75ee20e7a0cf52c6ce4a696ee3919e62630ea
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

7 Commits
frontend ... a7f75ee20e

Author SHA1 Message Date
Mats Rauhala
a7f75ee20e List books (#2) 2018-08-28 23:25:48 +03:00
Mats Rauhala
efa7ed7f92 WIP 2018-08-28 23:14:11 +03:00
Mats Rauhala
ce338f067b wip 2018-08-28 22:54:49 +03:00
Mats Rauhala
f55a982f57 wip 2018-08-28 22:41:59 +03:00
Mats Rauhala
3f1b2d3588 wip 2018-08-28 22:38:57 +03:00
Mats Rauhala
83e39cbe6c Start implementing channel listing (#2) 2018-08-28 22:38:07 +03:00
Mats Rauhala
e50e234747 Start working opds (#2) 
- Relates to #2
 2018-08-28 22:37:57 +03:00
45 changed files with 328 additions and 982 deletions
Expand all files Collapse all files

4
.gitignore vendored
View File

@ -1,6 +1,2 @@
dist/ dist/
config/config.dhall config/config.dhall
/ctags
/TAGS
/result*
/backend/config

12
.travis.yml
View File

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

5
backend/ChangeLog.md
View File

@ -1,5 +0,0 @@
# Revision history for backend
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

30
backend/LICENSE
View File

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

2
backend/Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

48
backend/src/API.hs
View File

@ -1,48 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module API (API, handler) where
import Servant
import Servant.HTML.Lucid (HTML)
import Types
import View
import qualified API.Books as Books
import qualified API.Catalogue as Catalogue
import qualified API.Channels as Channels
import qualified API.Users as Users
data Index = Index
type 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
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

51
backend/src/Server.hs
View File

@ -1,51 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Server where
import qualified API as 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)
import Server.Auth (authCheck)
import Types
type API = API.API
:<|> "help" :> Get '[PlainText, HTML] String
:<|> "static" :> Raw
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 :<|> serveDirectoryFileServer "static")
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

65
backend/src/Spec.hs
View File

@ -1,65 +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
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
it "Works for PlainPassword" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @PlainPassword) A.decode
it "Works for Email" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Email) A.decode
it "Username" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Username) A.decode
it "Works for BookID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @BookID) A.decode
it "Works for ChannelID" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @ChannelID) A.decode
it "Works for Role" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Role) A.decode
it "Works for Visibility" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @Visibility) A.decode
it "Works for JsonBook" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @JsonBook) A.decode
it "Works for PostBook" $ inverseFunctionsIfSecondSucceedsOnValid (A.encode @PostBook) A.decode
main :: IO ()
main = hspec spec

30
common/LICENSE
View File

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

47
common/common.cabal
View File

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

9
common/src/Spec.hs
View File

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

70
default.nix
View File

@ -1,62 +1,10 @@
{ nixpkgs, haskellPackages }: { mkDerivation, base, stdenv }:
mkDerivation {
let pname = "ebook-manager";
miso = nixpkgs.fetchFromGitHub { version = "0.1.0.0";
owner = "dmjio"; src = ./.;
repo = "miso"; isLibrary = false;
rev = "630e823dd40a434b73124e12b229a79d9fefb01d"; isExecutable = true;
sha256 = "046gdp3ah2lsipfcy89rh20mn08xbhcgrj549v8zzy69j33xjm2l"; executableHaskellDepends = [ base ];
}; license = stdenv.lib.licenses.bsd3;
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
];
} }

81
backend/backend.cabal → ebook-manager.cabal
View File

@ -1,7 +1,4 @@
-- Initial backend.cabal generated by cabal init. For further name: ebook-manager
-- documentation, see http://haskell.org/cabal/users-guide/
name: backend
version: 0.1.0.0 version: 0.1.0.0
-- synopsis: -- synopsis:
-- description: -- description:
@ -15,7 +12,7 @@ build-type: Simple
extra-source-files: ChangeLog.md extra-source-files: ChangeLog.md
cabal-version: >=1.10 cabal-version: >=1.10
executable backend executable ebook-manager
main-is: Main.hs main-is: Main.hs
other-modules: Devel.Main other-modules: Devel.Main
, API , API
@ -24,6 +21,7 @@ executable backend
, API.Channels , API.Channels
, API.Users , API.Users
, Configuration , Configuration
, Data.Versioned
, Database , Database
, Database.Book , Database.Book
, Database.Channel , Database.Channel
@ -37,10 +35,7 @@ executable backend
, Types , Types
, View , View
-- other-extensions: -- other-extensions:
build-depends: base >=4.10 build-depends: base >=4.10 && <4.11
, exceptions
, monad-control
, common
, aeson , aeson
, asn1-data , asn1-data
, asn1-types , asn1-types
@ -69,7 +64,6 @@ executable backend
, servant , servant
, servant-auth , servant-auth
, servant-auth-server , servant-auth-server
, servant-auth-docs
, servant-docs , servant-docs
, servant-lucid , servant-lucid
, servant-multipart , servant-multipart
@ -83,67 +77,8 @@ executable backend
, xml-conduit , xml-conduit
, xml-hamlet , xml-hamlet
hs-source-dirs: src hs-source-dirs: src
default-extensions: DeriveGeneric
, NoImplicitPrelude
, OverloadedStrings
, RecordWildCards
default-language: Haskell2010 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
, exceptions
, monad-control
, common
, aeson
, asn1-data
, asn1-types
, bytestring
, classy-prelude
, cryptonite
, dhall
, directory
, foreign-store
, generic-lens
, http-api-data
, http-media
, jose
, lens
, lucid
, memory
, monad-logger
, mtl
, pandoc
, pandoc-types
, pem
, process
, resource-pool
, selda
, selda-postgresql
, servant
, servant-auth
, servant-auth-server
, servant-docs
, servant-auth-docs
, servant-lucid
, servant-multipart
, servant-server
, text
, transformers
, wai
, warp
, x509
, x509-store
, xml-conduit
, xml-hamlet
, validity
, genvalidity-hspec
, genvalidity-property
, genvalidity-text
, hspec
default-extensions: DeriveGeneric
, NoImplicitPrelude
, OverloadedStrings
, RecordWildCards

5
frontend/ChangeLog.md
View File

@ -1,5 +0,0 @@
# Revision history for frontend
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.

30
frontend/LICENSE
View File

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

2
frontend/Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

28
frontend/frontend.cabal
View File

@ -1,28 +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
, miso
, jsaddle-warp
, mtl
, common
hs-source-dirs: src
default-language: Haskell2010

41
frontend/src/Main.hs
View File

@ -1,41 +0,0 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Control.Monad.Trans (liftIO)
import Language.Javascript.JSaddle.Warp
import Miso
import Miso.String
data Action = Add
| Subtract
| SayHello
| NoOp
newtype Model = Model Int deriving (Eq, Num, ToMisoString)
updateModel :: Action -> Model -> Effect Action Model
updateModel Add m = noEff (m + 1)
updateModel Subtract m = noEff (m - 1)
updateModel SayHello m = m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
updateModel NoOp m = noEff m
viewModel :: Model -> View Action
viewModel x =
div_ [] [ button_ [ onClick Add ] [ text "+" ]
, text (ms x)
, button_ [ onClick Subtract ] [ text "-" ]
]
main :: IO ()
main = run 8081 $ startApp App{..}
where
model = Model 0
initialAction = SayHello
update = updateModel
view = viewModel
subs = []
events = defaultEvents
mountPoint = Nothing

16
ghcjs.patch
View File

@ -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);
}

14
jsaddle-warp-ghcjs.nix
View File

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

1
migrations/V1.2__unique_tags.sql
View File

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

4
nixpkgs-version.json
View File

@ -1,7 +1,7 @@
{ {
"url": "https://github.com/nixos/nixpkgs.git", "url": "https://github.com/nixos/nixpkgs.git",
"rev": "4507926b80c6b8f73053775ffee17f6781c7e7c8", "rev": "83a5765b1fea2472ec9cf9d179d3efd18b45c77e",
"date": "2018-01-08T11:52:28+01:00", "date": "2018-01-08T11:52:28+01:00",
"sha256": "068v9xh7d8klk62p2qwr76fyfqfh1bp08xc12x138g5q6pg6yfzb", "sha256": "01rb61dkbzjbwnb3p8lgs03a94f4584199dlr0cwdmqzaxnp506h",
"fetchSubmodules": true "fetchSubmodules": true
} }

45
project.nix
View File

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

@ -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 = [ ];
};
}

50
src/API.hs Normal file
View File

@ -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" :> "current" :> Channels.API
:<|> "api" :> "current" :> 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

85
backend/src/API/Books.hs → src/API/Books.hs
View File

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

38
backend/src/API/Catalogue.hs → src/API/Catalogue.hs
View File

@ -16,19 +16,17 @@
{-# Language ScopedTypeVariables #-} {-# Language ScopedTypeVariables #-}
module API.Catalogue (VersionedAPI, handler) where module API.Catalogue (VersionedAPI, handler) where
import qualified API.Books
import ClassyPrelude
import Database
import Database.Book (Book(..))
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 Types
import Servant hiding (contentType)
import ClassyPrelude
import GHC.TypeLits
import Server.Auth
import Servant.Auth as SA
import Servant.XML
import qualified Database.Channel as Channel
import Database.Book (Book(..))
import Database
import qualified API.Books
-- This is my first try on going to versioned apis, things might change -- This is my first try on going to versioned apis, things might change
-- I think my rule of thumb is that you can add new things as you want, but -- I think my rule of thumb is that you can add new things as you want, but
@ -42,7 +40,7 @@ newtype Rel = Rel { unRel :: Text } deriving (IsString, Show)
data Pagination = Pagination { previous :: Maybe Rel data Pagination = Pagination { previous :: Maybe Rel
, next :: Maybe Rel } , next :: Maybe Rel }
deriving (Show, Generic) deriving (Show)
newtype SubSection = SubSection Rel deriving (Show) newtype SubSection = SubSection Rel deriving (Show)
newtype Acquisition = Acquisition Rel deriving (Show) newtype Acquisition = Acquisition Rel deriving (Show)
@ -66,20 +64,6 @@ deriving instance Show (Entry 1)
deriving instance Generic (Catalog 1) deriving instance Generic (Catalog 1)
deriving instance Generic (Entry 1) deriving instance Generic (Entry 1)
instance Docs.ToSample (Entry 1) where
toSamples _ = [("Entry", EntryV1 "title" "identifier" docsTime "content" (Left (SubSection (Rel "sub"))))]
instance Docs.ToSample UTCTime where
toSamples _ = [("time", docsTime)]
instance Docs.ToSample Rel where
toSamples _ = [("Relative link", Rel "next")]
instance Docs.ToSample Pagination
instance Docs.ToSample (Catalog 1) -- where
-- toSamples _ = [("catalog", CatalogV1 docsTime (Rel "prev") (Rel "next") (Pagination (Just "previous") (Just "next")) [])]
docsTime :: UTCTime
docsTime = unsafePerformIO getCurrentTime
instance ToNode SubSection where instance ToNode SubSection where
toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|] toNode (SubSection rel) = [xml|<link type="application/atom+xml;profile=opds-catalog;kind=acquisition" rel="subsection" href="#{unRel rel}">|]

54
backend/src/API/Channels.hs → src/API/Channels.hs
View File

@ -1,32 +1,31 @@
{-# LANGUAGE DataKinds #-} {-# Language DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# Language TypeFamilies #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# Language TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-} {-# Language NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# Language MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# Language OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# Language TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-} {-# Language QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-} {-# Language RecordWildCards #-}
{-# LANGUAGE RecordWildCards #-} {-# Language DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-} {-# Language FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-} {-# Language TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# Language DataKinds #-}
{-# LANGUAGE TypeOperators #-} {-# Language DuplicateRecordFields #-}
{-# Language NamedFieldPuns #-}
module API.Channels (API, handler, JsonChannel(..)) where module API.Channels (API, handler, JsonChannel(..)) where
import Servant
import Types
import ClassyPrelude import ClassyPrelude
import Control.Lens import Server.Auth
import Control.Monad.Catch (MonadThrow, throwM) import Servant.Auth as SA
import Control.Monad.Logger import Control.Monad.Logger
import Data.Aeson
import Data.Generics.Product
import Database import Database
import Database.Channel import Database.Channel
import Servant import Data.Aeson
import Servant.Auth as SA import Control.Lens
import qualified Servant.Docs as Docs import Data.Generics.Product
import Server.Auth
import Types
data JsonChannel = JsonChannel { channel :: Text data JsonChannel = JsonChannel { channel :: Text
, visibility :: Visibility } , visibility :: Visibility }
@ -36,12 +35,6 @@ data UpdateChannel = UpdateChannel { identifier :: ChannelID
, visibility :: Visibility } , visibility :: Visibility }
deriving (Show, Generic) deriving (Show, Generic)
instance Docs.ToSample JsonChannel where
toSamples _ = [("Channel", JsonChannel "channel" Private)]
instance Docs.ToSample UpdateChannel where
toSamples _ = [("Channel", UpdateChannel 13 "channel" Private)]
instance ToJSON JsonChannel instance ToJSON JsonChannel
instance FromJSON JsonChannel instance FromJSON JsonChannel
instance ToJSON UpdateChannel instance ToJSON UpdateChannel
@ -49,9 +42,6 @@ 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]

23
backend/src/API/Users.hs → src/API/Users.hs
View File

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

5
backend/src/Configuration.hs → src/Configuration.hs
View File

@ -12,9 +12,7 @@ data Pg = Pg { username :: Text
, database :: Text } , database :: Text }
deriving (Show, Generic) deriving (Show, Generic)
data Store = Filestore { path :: Text } newtype Store = Store { path :: Text } deriving (Show, Generic)
| IPFS { common :: Text }
deriving (Show, Generic)
data Config = Config { database :: Pg data Config = Config { database :: Pg
, store :: Store } , store :: Store }
@ -23,4 +21,3 @@ data Config = Config { database :: Pg
instance Interpret Pg instance Interpret Pg
instance Interpret Store instance Interpret Store
instance Interpret Config instance Interpret Config

0
common/src/Data/Versioned.hs → src/Data/Versioned.hs
View File

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

@ -15,17 +15,15 @@ module Database
, SeldaT ) , SeldaT )
where where
import ClassyPrelude
import Control.Lens (view)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Generics.Product import Data.Generics.Product
import Control.Lens (view)
import Data.Pool (Pool, withResource) import Data.Pool (Pool, withResource)
import Database.Selda (query, select, transaction)
import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT) import Database.Selda.Backend (SeldaConnection, runSeldaT, SeldaT)
import Database.Selda (query, select, transaction)
import Database.Selda.Generic (gen, fromRel, fromRels, toRel) 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 :: DBLike r m => SeldaT m a -> m a
runDB q = do runDB q = do

29
backend/src/Database/Book.hs → src/Database/Book.hs
View File

@ -18,17 +18,18 @@ module Database.Book
, BookID) where , BookID) where
import ClassyPrelude 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.Schema (books, users, Username, Book(..), BookID(..), UserID, HashDigest(..))
import Database
import Database.Selda import Database.Selda
import Database.Selda.Generic 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 usersBooks username = fromRels <$> query q
where where
q = do q = do
@ -40,7 +41,7 @@ usersBooks username = fromRels <$> query q
return book 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 getBook identifier owner = listToMaybe . fromRels <$> query q
where where
q = do q = do
@ -55,7 +56,7 @@ data InsertBook = InsertBook { contentType :: Text
, owner :: Username } , owner :: Username }
-- Always inserts -- 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 insertBook InsertBook{..} = do
mUserId <- query $ do mUserId <- query $ do
userId :*: _ :*: username' :*: _ <- select (gen users) userId :*: _ :*: username' :*: _ <- select (gen users)
@ -74,7 +75,7 @@ data UpdateBook = UpdateBook { identifier :: BookID
, channels :: [Text] } , channels :: [Text] }
deriving (Show, Generic) 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 bookExists identifier = not . null <$> query q
where where
q = do q = do
@ -82,7 +83,7 @@ bookExists identifier = not . null <$> query q
restrict (bookId .== literal identifier) restrict (bookId .== literal identifier)
return bookId 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) isBookOwner identifier username = not . null <$> query (bookOwner' identifier username)
bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID) bookOwner' :: BookID -> Username -> Query s (Col s UserID :*: Col s BookID)
@ -94,7 +95,7 @@ bookOwner' identifier username = do
restrict (bookId .== literal identifier) restrict (bookId .== literal identifier)
return (userId :*: bookId) 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 updateBook UpdateBook{..} = do
clearTags identifier >> connectTags clearTags identifier >> connectTags
clearChannels identifier >> connectChannels clearChannels identifier >> connectChannels
@ -113,7 +114,7 @@ updateBook UpdateBook{..} = do
predicate (bookId :*: _) = bookId .== literal identifier 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 getUpdateBook bookId username = do
mBook <- getBook bookId username mBook <- getBook bookId username
forM mBook $ \Book{..} -> do forM mBook $ \Book{..} -> do
@ -121,7 +122,7 @@ getUpdateBook bookId username = do
tags <- map (view (field @"tag")) <$> booksTags bookId tags <- map (view (field @"tag")) <$> booksTags bookId
return UpdateBook{owner=username,..} 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 setContent identifier owner digest = do
mOwner <- query (bookOwner' identifier owner) mOwner <- query (bookOwner' identifier owner)
void $ forM (listToMaybe mOwner) $ \_ -> void $ forM (listToMaybe mOwner) $ \_ ->

19
backend/src/Database/Channel.hs → src/Database/Channel.hs
View File

@ -17,15 +17,14 @@ module Database.Channel
where where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Catch (MonadMask)
import Database
import Database.Schema import Database.Schema
import Database
import Database.Selda import Database.Selda
import Database.Selda.Generic import Database.Selda.Generic
import Control.Monad.Trans.Maybe 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 getChannel identifier = listToMaybe . fromRels <$> query q
where where
q = do q = do
@ -33,10 +32,10 @@ getChannel identifier = listToMaybe . fromRels <$> query q
restrict (channelId .== literal identifier) restrict (channelId .== literal identifier)
return ch 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 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 isChannelOwner identifier username = not . null <$> query q
where where
q = do q = do
@ -57,7 +56,7 @@ userChannels username = fromRels <$> query q
restrict (username' .== literal username) restrict (username' .== literal username)
return channel 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 updateChannelPrivacy channelId visibility = do
void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility]) void $ update (gen channels) predicate (\channel -> channel `with` [pVis := literal visibility])
getChannel channelId getChannel channelId
@ -82,7 +81,7 @@ insertChannel username channel visibility = runMaybeT $ do
restrict (user .== literal username) restrict (user .== literal username)
return userId return userId
channelBooks :: (MonadSelda m, MonadIO m) => Username -> ChannelID -> m [Book] channelBooks :: (MonadSelda m, MonadMask m, MonadIO m) => Username -> ChannelID -> m [Book]
channelBooks username identifier = fromRels <$> query q channelBooks username identifier = fromRels <$> query q
where where
q = do q = do
@ -95,7 +94,7 @@ channelBooks username identifier = fromRels <$> query q
restrict (bookId .== bookId') restrict (bookId .== bookId')
return book 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 booksChannels bookId = fromRels <$> query q
where where
q = do q = do
@ -105,7 +104,7 @@ booksChannels bookId = fromRels <$> query q
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return ch 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 attachChannel username bookId channel = do
mCh <- fromRels <$> query channelQ mCh <- fromRels <$> query channelQ
forM_ mCh $ \Channel{identifier} -> forM_ mCh $ \Channel{identifier} ->
@ -124,5 +123,5 @@ attachChannel username bookId channel = do
restrict (channel' .== literal channel) restrict (channel' .== literal channel)
return ch 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) clearChannels bookId = deleteFrom (gen bookChannels) (\(_ :*: bookId') -> bookId' .== literal bookId)

39
backend/src/Database/Schema.hs → src/Database/Schema.hs
View File

@ -1,35 +1,26 @@
{-# LANGUAGE DeriveGeneric #-} {-# Language NoImplicitPrelude #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# Language DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# Language OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# Language DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-} {-# Language GeneralizedNewtypeDeriving #-}
module Database.Schema where module Database.Schema where
import ClassyPrelude import ClassyPrelude
import Data.Aeson import Database.Selda.Generic
import Database.Selda import Database.Selda
import Database.Selda.Backend import Database.Selda.Backend
import Database.Selda.Generic
import qualified Servant.Docs as Docs import Data.Aeson
import Web.HttpApiData import Web.HttpApiData
-- | User type -- | User type
newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq, Generic) newtype PlainPassword = PlainPassword Text deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Eq)
newtype HashedPassword = HashedPassword {unHashed :: ByteString} newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword data NoPassword = NoPassword
newtype Email = Email { unEmail :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData, Generic, Eq, 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) newtype Username = Username { unUsername :: Text } deriving (Show, ToJSON, FromJSON, ToHttpApiData, FromHttpApiData)
instance Docs.ToSample Username where
toSamples _ = [("Username", Username "user123")]
instance Docs.ToSample Email where
toSamples _ = [("Email", Email "first.last@example.com")]
instance Docs.ToSample PlainPassword where
toSamples _ = [("Password", PlainPassword "password123")]
instance SqlType HashedPassword where instance SqlType HashedPassword where
mkLit = LCustom . LBlob . unHashed mkLit = LCustom . LBlob . unHashed
@ -51,9 +42,9 @@ instance SqlType Username where
newtype UserID = UserID {unUserID :: Int} deriving (Show) newtype UserID = UserID {unUserID :: Int} deriving (Show)
newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData, Generic, Num) newtype BookID = BookID {unBookID :: Int} deriving (Show, ToJSON, FromJSON, FromHttpApiData, Eq, Ord, ToHttpApiData)
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)
newtype TagID = TagID {unTagID :: Int} deriving (Show) newtype TagID = TagID {unTagID :: Int} deriving (Show)
@ -86,7 +77,7 @@ data User pass = User { identifier :: UserID
, password :: pass } , password :: pass }
deriving (Show, Generic) deriving (Show, Generic)
data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic, Eq) data Role = UserRole | AdminRole deriving (Show, Read, Enum, Bounded, Typeable, Generic)
instance ToJSON Role instance ToJSON Role
instance FromJSON Role instance FromJSON Role
@ -134,7 +125,7 @@ data Tag = Tag { identifier :: TagID
deriving (Show, Generic) deriving (Show, Generic)
data Visibility = Public | Private | Followers data Visibility = Public | Private | Followers
deriving (Show, Read, Generic, Eq) deriving (Show, Read, Generic)
instance ToJSON Visibility instance ToJSON Visibility
instance FromJSON Visibility instance FromJSON Visibility

13
backend/src/Database/Tag.hs → src/Database/Tag.hs
View File

@ -12,14 +12,13 @@ module Database.Tag
, Tag(..) ) where , Tag(..) ) where
import ClassyPrelude import ClassyPrelude
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Trans.Maybe
import Database
import Database.Schema import Database.Schema
import Database
import Database.Selda import Database.Selda
import Database.Selda.Generic 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 upsertTag username tag = runMaybeT $ do
userId <- MaybeT (listToMaybe <$> query userQ) userId <- MaybeT (listToMaybe <$> query userQ)
void $ lift $ upsert (gen tags) (predicate userId) id [toRel (Tag def tag userId)] 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) restrict (username' .== literal username)
return userId 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 booksTags bookId = fromRels <$> query q
where where
q = do q = do
@ -45,7 +44,7 @@ booksTags bookId = fromRels <$> query q
restrict (bookId' .== literal bookId) restrict (bookId' .== literal bookId)
return tag 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 attachTag username bookId tag = do
maybeT <- upsertTag username tag maybeT <- upsertTag username tag
forM_ maybeT $ \Tag{identifier} -> do forM_ maybeT $ \Tag{identifier} -> do
@ -57,6 +56,6 @@ attachTag username bookId tag = do
restrict (tagId' .== literal tagId .&& bookId' .== literal bookId) restrict (tagId' .== literal tagId .&& bookId' .== literal bookId)
return tagId' 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) clearTags bookId = deleteFrom (gen bookTags) (\(_ :*: bookId') -> bookId' .== literal bookId)

15
backend/src/Database/User.hs → src/Database/User.hs
View File

@ -5,21 +5,20 @@
module Database.User where module Database.User where
import ClassyPrelude 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
import Database.Schema import Database.Schema
import Database.Selda 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)
data UserExistsError = UserExistsError 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) = insertUser username email (PlainPassword password) =
getUser' username >>= maybe insert' (const (return $ Left UserExistsError)) getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
where where

17
backend/src/Datastore.hs → src/Datastore.hs
View File

@ -5,7 +5,6 @@
{-# Language FlexibleContexts #-} {-# Language FlexibleContexts #-}
{-# Language TypeSynonymInstances #-} {-# Language TypeSynonymInstances #-}
{-# Language FlexibleInstances #-} {-# Language FlexibleInstances #-}
{-# Language ScopedTypeVariables #-}
module Datastore where module Datastore where
import ClassyPrelude import ClassyPrelude
@ -29,26 +28,26 @@ instance MonadDS AppM where
get = getLocal get = getLocal
putLocal :: ( MonadIO m putLocal :: ( MonadIO m
, HasField "config" r r config config , HasField' "config" r config
, HasField "store" config config store store , HasField' "store" config store
, HasType Text store , HasField' "path" store Text
, MonadReader r m) , MonadReader r m)
=> ByteString -> m (Digest SHA256) => ByteString -> m (Digest SHA256)
putLocal bs = do 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 liftIO $ createDirectoryIfMissing True store
let key = hashWith SHA256 bs let key = hashWith SHA256 bs
writeFile (store </> show key) bs writeFile (store </> show key) bs
return key return key
getLocal :: ( MonadIO m getLocal :: ( MonadIO m
, HasField "config" r r config config , HasField' "config" r config
, HasField "store" config config store store , HasField' "store" config store
, HasType Text store , HasField' "path" store Text
, MonadReader r m) , MonadReader r m)
=> Digest SHA256 -> m (Maybe ByteString) => Digest SHA256 -> m (Maybe ByteString)
getLocal key = do 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 liftIO $ createDirectoryIfMissing True store
let file = store </> show key let file = store </> show key
exists <- liftIO $ doesFileExist file exists <- liftIO $ doesFileExist file

17
backend/src/Devel/Main.hs → src/Devel/Main.hs
View File

@ -3,18 +3,19 @@
{-# Language FlexibleContexts #-} {-# Language FlexibleContexts #-}
module Devel.Main where module Devel.Main where
import Prelude
import Control.Monad.Trans.Reader (runReaderT)
import Main (withApp, defaultMain)
import Control.Concurrent import Control.Concurrent
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.Trans.Reader (runReaderT)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) 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 Foreign.Store (Store(..), lookupStore, readStore, storeAction, withStore)
import GHC.Word (Word32) import GHC.Word (Word32)
import Main (withApp, defaultMain) import Dhall (input, auto)
import Prelude
import Database.Schema
import Database.Selda (tryCreateTable)
import Database
update :: IO () update :: IO ()
update = do update = do
@ -36,7 +37,7 @@ update = do
develMain :: IO () develMain :: IO ()
develMain = do develMain = do
conf <- input auto "../config/devel.dhall" conf <- input auto "./config/devel.dhall"
withApp conf $ \app -> do withApp conf $ \app -> do
void $ runReaderT (runDB migrate) app void $ runReaderT (runDB migrate) app
defaultMain app defaultMain app

1
backend/src/Main.hs → src/Main.hs
View File

@ -25,7 +25,6 @@ withApp :: Config -> (App -> IO ()) -> IO ()
withApp config f = do withApp config f = do
let pgHost = view (field @"database" . field @"host") config let pgHost = view (field @"database" . field @"host") config
pgPort = 5432 pgPort = 5432
pgSchema = Nothing
pgDatabase = view (field @"database" . field @"database") config pgDatabase = view (field @"database" . field @"database") config
pgUsername = Just (view (field @"database" . field @"username") config) pgUsername = Just (view (field @"database" . field @"username") config)
pgPassword = Just (view (field @"database" . field @"password") config) pgPassword = Just (view (field @"database" . field @"password") config)

0
backend/src/Servant/XML.hs → src/Servant/XML.hs
View File

40
src/Server.hs Normal file
View File

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

35
backend/src/Server/Auth.hs → src/Server/Auth.hs
View File

@ -1,11 +1,11 @@
{-# LANGUAGE DataKinds #-} {-# Language DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# Language TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# Language OverloadedStrings #-}
{-# LANGUAGE OverloadedStrings #-} {-# Language NoImplicitPrelude #-}
{-# LANGUAGE TemplateHaskell #-} {-# Language TypeOperators #-}
{-# LANGUAGE TypeApplications #-} {-# Language DuplicateRecordFields #-}
{-# LANGUAGE TypeFamilies #-} {-# Language TypeApplications #-}
{-# LANGUAGE TypeOperators #-} {-# Language TemplateHaskell #-}
module Server.Auth module Server.Auth
( SafeUser(..) ( SafeUser(..)
, authCheck , authCheck
@ -14,18 +14,16 @@ module Server.Auth
where where
import ClassyPrelude import ClassyPrelude
import Control.Lens (view) import Servant.Auth.Server as SAS
import Control.Monad.Catch (MonadThrow, throwM)
import Control.Monad.Logger
import Data.Aeson import Data.Aeson
import Data.Generics.Product
import Database
import Database.Schema import Database.Schema
import Database.User import Database.User
import Servant (err401) import Database
import Servant.Auth.Server as SAS
import qualified Servant.Docs as Docs
import Types 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 -- generic-lens can convert similar types to this
-- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone -- I'm trying out servant-auth-server which uses a jwt style login. IIRC anyone
@ -37,9 +35,6 @@ data SafeUser = SafeUser { email :: Email
, role :: Role } , role :: Role }
deriving (Show, Generic) deriving (Show, Generic)
instance Docs.ToSample SafeUser where
toSamples _ = [("User", SafeUser "user@example.com" "user" UserRole )]
instance ToJSON SafeUser where instance ToJSON SafeUser where
instance FromJSON SafeUser where instance FromJSON SafeUser where
instance ToJWT SafeUser where instance ToJWT SafeUser where
@ -58,6 +53,6 @@ authCheck app (BasicAuthData username password) = flip runReaderT app $
password' = PlainPassword $ decodeUtf8 password password' = PlainPassword $ decodeUtf8 password
authenticated = SAS.Authenticated . view (super @SafeUser) 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 f (Authenticated user) = f user
requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401 requireLoggedIn _ u = $logError (pack (show u)) >> throwM err401

0
backend/src/Types.hs → src/Types.hs
View File

0
backend/src/View.hs → src/View.hs
View File