Deprecation notice

.travis.yml

@@ -8,5 +8,5 @@ before_script:
   - 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
+  - nix build -f ./release.nix --option trusted-public-keys "masser-ebook-manager.cachix.org-1:mtFSkQ2MO5MvjUpulZoFKjKUIa8g8CTcdPVuJaPKS1w= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option binary-caches "https://masser-ebook-manager.cachix.org https://cache.nixos.org" ghc.backend ghc.frontend
+  - nix build -f ./release.nix --option trusted-public-keys "masser-ebook-manager.cachix.org-1:mtFSkQ2MO5MvjUpulZoFKjKUIa8g8CTcdPVuJaPKS1w= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=" --option binary-caches "https://masser-ebook-manager.cachix.org https://cache.nixos.org" ghcjs.frontend

README.md

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

backend/src/API.hs

@@ -1,12 +1,7 @@
 {-# 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
@@ -20,7 +15,7 @@ import qualified API.Catalogue      as Catalogue
 import qualified API.Channels       as Channels
 import qualified API.Users          as Users
 
-type API = Users.API
+type API = "api" :> Users.API
       :<|> "api" :> "current" :> Channels.API
       :<|> "api" :> "current" :> Books.API
       :<|> "api" :> "1" :> Catalogue.VersionedAPI 1

backend/src/Configuration.hs

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

backend/src/Main.hs

@@ -8,7 +8,7 @@ module Main where
 
 import           ClassyPrelude
 import           Configuration
-import           Control.Lens              (view)
+import           Control.Lens              (view, to)
 import           Data.Generics.Product
 import           Data.Pool                 (createPool)
 import           Database.Selda.PostgreSQL (PGConnectInfo (..), pgOpen,
@@ -21,7 +21,7 @@ import           Types
 import System.Environment (getEnvironment)
 
 defaultMain :: App -> IO ()
-defaultMain = run 8080 . server
+defaultMain app = run (view (field @"config" . field @"port" . to fromIntegral) app) $ server app
 
 withApp :: Config -> (App -> IO ()) -> IO ()
 withApp config f = do

backend/src/Server.hs

@@ -1,19 +1,15 @@
 {-# 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 qualified API
 import           ClassyPrelude         hiding (Handler)
 import           Control.Lens
 import           Control.Monad.Except
@@ -24,18 +20,16 @@ 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           Server.Auth           (SafeUser, authCheck)
 import           Types
 
 type API = API.API
-  :<|> "help" :> Get '[PlainText, HTML] String
-  :<|> "static" :> Raw
+  :<|> "api" :> "help" :> Get '[PlainText, HTML] String
 
 type Ctx = '[BasicAuthData -> IO (AuthResult SafeUser), CookieSettings, JWTSettings]
 
 server :: App -> Application
-server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs :<|> serveDirectoryFileServer "static")
+server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API) (Proxy @ Ctx) server' API.handler :<|> serveDocs)
   where
     apiDocs :: Docs.API
     apiDocs = Docs.docs (Proxy @API.API)
@@ -46,6 +40,6 @@ server app = serveWithContext api cfg (hoistServerWithContext (Proxy @ API.API)
     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")
+    server' = Handler . ExceptT . try . (`runReaderT` app) . runFileLoggingT "logs/server.log"
     api :: Proxy API
     api = Proxy

config/Configuration.dhall

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

config/config.dhall.sample

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

frontend/frontend.cabal

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

frontend/src/Main.hs

@@ -1,41 +1,93 @@
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE ScopedTypeVariables          #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE GADTs              #-}
 module Main where
 
+import           Control.Lens                     (over, set)
 import           Control.Monad.Trans              (liftIO)
+import           Data.Generics.Product
+import           GHC.Generics                     (Generic)
 import           Language.Javascript.JSaddle.Warp
-import           Miso
+import           Miso                             hiding (set)
 import           Miso.String
+import           Servant.API
+import           Servant.Links
+import Data.Proxy (Proxy(..))
+
+type API = Home :<|> Login :<|> Register
+type Home = View Action
+type Login = "login" :> View Action
+type Register = "register" :> View Action
 
 data Action = Add
             | Subtract
             | SayHello
+            | HandleURI URI
+            | ChangeURI URI
             | NoOp
 
-newtype Model = Model Int deriving (Eq, Num, ToMisoString)
+data Model = Model { counter :: Int
+                   , uri     :: URI }
+  deriving (Eq, Generic)
 
-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
+updateModel :: Model -> Action -> Effect Action Model
+updateModel m = \case
+  Add -> noEff (over (field @"counter") (+1) m)
+  Subtract -> noEff (over (field @"counter") (\x -> x - 1) m)
+  SayHello -> m <# (liftIO (putStrLn "Hello world") >> pure NoOp)
+  HandleURI uri -> noEff (set (field @"uri") uri m)
+  ChangeURI uri -> m <# do
+    liftIO $ putStrLn $ "Pushing uri " <> show uri
+    pushURI uri
+    return $ HandleURI uri
+  NoOp -> noEff m
 
 viewModel :: Model -> View Action
-viewModel x =
-  div_ [] [ button_  [ onClick Add ] [ text "+" ]
-          , text (ms x)
+viewModel model = view
+  where
+    view = either (const the404) id $ runRoute @API Proxy handlers uri model
+    handlers = home :<|> login :<|> register
+    home _ = div_ [] [ button_  [ onClick Add ] [ text "+" ]
+              , text (ms (counter model))
               , button_ [ onClick Subtract ] [ text "-" ]
+              , button_ [ onClick goLogin ] [ text "go login" ]
+              , button_ [ onClick goRegister ] [ text "go register" ]
             ]
+    login _ = div_ [] []
+    register _ = div_ [] [
+        h3_ [] [text "register"]
+      , label_ [] [text "Username"], input_ [id_ "username", name_ "username"]
+      , label_ [] [text "Email"], input_ [id_ "email", name_ "email"]
+      , label_ [] [text "Password"], input_ [id_ "password", name_ "password"]
+      , label_ [] [text "Password again"], input_ [id_ "passwordAgain", name_ "passwordAgain"]
+      , button_ [] [text "Register"]
+      ]
+    the404 = div_ [] []
+
+goLogin, goHome, goRegister :: Action
+goLogin = goto @Login @API Proxy Proxy
+goHome = goto @Home @API Proxy Proxy
+goRegister = goto @Register @API Proxy Proxy
+
+goto :: (IsElem endpoint api, HasLink endpoint, MkLink endpoint Link ~ Link) => Proxy api -> Proxy endpoint -> Action
+goto a b = ChangeURI (linkURI (safeLink a b))
 
 main :: IO ()
-main = run 8081 $ startApp App{..}
+main = run 8081 $ do
+  model <- mkModel
+  startApp App{..}
   where
-    model = Model 0
+    mkModel = Model <$> pure 0 <*> getCurrentURI
     initialAction = SayHello
-    update = updateModel
+    update = flip updateModel
     view = viewModel
-    subs = []
+    subs = [ uriSub HandleURI ]
     events = defaultEvents
     mountPoint = Nothing

to-flyway.dhall

@@ -0,0 +1,8 @@
+\(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}
+''