Fix type

README.md

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

backend/src/Configuration.hs

@@ -18,8 +18,7 @@ data Store = Filestore { path :: Text }
            deriving (Show, Generic)
 
 data Config = Config { database :: Pg
-                     , store :: Store
-                     , port :: Integer }
+                     , store :: Store }
             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, to)
+import           Control.Lens              (view)
 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 app = run (view (field @"config" . field @"port" . to fromIntegral) app) $ server app
+defaultMain = run 8080 . server
 
 withApp :: Config -> (App -> IO ()) -> IO ()
 withApp config f = do

backend/src/Server.hs

@@ -1,15 +1,19 @@
 {-# 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
+import qualified API                   as API
 import           ClassyPrelude         hiding (Handler)
 import           Control.Lens
 import           Control.Monad.Except
@@ -20,16 +24,18 @@ import           Servant.Auth.Docs     ()
 import           Servant.Auth.Server   as SAS
 import qualified Servant.Docs          as Docs
 import           Servant.HTML.Lucid    (HTML)
-import           Server.Auth           (SafeUser, authCheck)
+import           Server.Auth           (SafeUser)
+import           Server.Auth           (authCheck)
 import           Types
 
 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]
 
 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
     apiDocs :: Docs.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}
     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

@@ -3,6 +3,5 @@
              , host : Text
              , database : Text
              , migrations : Text }
-, store : < Filestore : { path : Text } | IPFS : { common : Text } >
-, port : Integer
+, store : < Filestore = { path : Text } | IPFS = { common : Text } >
 }

frontend/frontend.cabal

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

frontend/src/Main.hs

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