diff --git a/.hindent.yaml b/.hindent.yaml new file mode 100644 index 0000000..c1e2911 --- /dev/null +++ b/.hindent.yaml @@ -0,0 +1,4 @@ +# We use 4 space indents. +indent-size: 4 +line-length: 80 +force-trailing-newline: false diff --git a/kucipong.cabal b/kucipong.cabal index c1695db..e0c927c 100644 --- a/kucipong.cabal +++ b/kucipong.cabal @@ -46,6 +46,7 @@ library , Kucipong.Monad.SendEmail.Trans , Kucipong.Orphans , Kucipong.Prelude + , Kucipong.RenderTemplate , Kucipong.Session , Kucipong.Spock , Kucipong.Util @@ -54,6 +55,7 @@ library , base64-bytestring , classy-prelude , clientsession + , ede , emailaddress , envelope , hailgun @@ -79,6 +81,8 @@ library , resource-pool , shakespeare , Spock + , template-haskell + , th-lift-instances , time , transformers , transformers-base @@ -87,7 +91,8 @@ library , warp default-language: Haskell2010 ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction - default-extensions: ConstraintKinds + default-extensions: BangPatterns + , ConstraintKinds , DataKinds , DefaultSignatures , DeriveDataTypeable @@ -121,7 +126,8 @@ executable kucipong build-depends: base , kucipong default-language: Haskell2010 - default-extensions: ConstraintKinds + default-extensions: BangPatterns + , ConstraintKinds , DataKinds , DefaultSignatures , DeriveDataTypeable @@ -159,7 +165,8 @@ executable kucipong-add-admin , optparse-applicative , persistent default-language: Haskell2010 - default-extensions: ConstraintKinds + default-extensions: BangPatterns + , ConstraintKinds , DataKinds , DefaultSignatures , DeriveDataTypeable diff --git a/src/Kucipong/Handler/Admin.hs b/src/Kucipong/Handler/Admin.hs index c0a6621..cce52f8 100644 --- a/src/Kucipong/Handler/Admin.hs +++ b/src/Kucipong/Handler/Admin.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TemplateHaskell #-} module Kucipong.Handler.Admin where @@ -5,9 +6,11 @@ import Kucipong.Prelude import Control.Lens ( (^.) ) import Control.Monad.Time ( MonadTime(..) ) +import Data.Aeson ( (.=) ) import Data.HVect ( HVect(..) ) import Database.Persist ( Entity(..) ) import Network.HTTP.Types ( forbidden403 ) +import Text.EDE ( eitherParse, eitherRender, fromPairs ) import Web.Spock ( ActionCtxT, Path, SpockCtxT, (), get, getContext, html, prehook, root , redirect, renderRoute, runSpock, setStatus, spockT, text, var ) @@ -18,10 +21,11 @@ import Kucipong.Db import Kucipong.LoginToken ( LoginToken ) import Kucipong.Monad ( MonadKucipongCookie, MonadKucipongDb(..), MonadKucipongSendEmail ) +import Kucipong.RenderTemplate ( renderTemplateFromEnv ) import Kucipong.Spock ( ContainsAdminSession, getAdminCookie, getAdminEmail, setAdminCookie ) import Kucipong.Session ( Admin, Session(..) ) -import Kucipong.Util ( fromMaybeM ) +import Kucipong.Util ( fromEitherM, fromMaybeM ) -- | Login an admin. Take the admin's 'LoginToken', and send them a session -- cookie. @@ -61,12 +65,13 @@ storeCreate :: forall xs n m . ( ContainsAdminSession n xs , MonadIO m + , MonadLogger m ) => ActionCtxT (HVect xs) m () storeCreate = do (AdminSession email) <- getAdminEmail - -- TODO: Actually return the correct html from here. - html $ "admin email: " <> tshow email + $(renderTemplateFromEnv "adminUser_admin_store_create.html") $ fromPairs + [ "adminEmail" .= email ] adminAuthHook :: ( MonadIO m @@ -89,6 +94,7 @@ adminComponent , MonadKucipongCookie m , MonadKucipongDb m , MonadKucipongSendEmail m + , MonadLogger m , MonadTime m ) => SpockCtxT (HVect xs) m () diff --git a/src/Kucipong/Monad/OtherInstances.hs b/src/Kucipong/Monad/OtherInstances.hs index 54bb2dd..781858a 100644 --- a/src/Kucipong/Monad/OtherInstances.hs +++ b/src/Kucipong/Monad/OtherInstances.hs @@ -1,14 +1,3 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Kucipong.Monad.OtherInstances where - -import Kucipong.Prelude - -import Control.Monad.Random ( MonadRandom(..) ) - -instance MonadRandom m => MonadRandom (LoggingT m) where - getRandom = lift getRandom - getRandomR = lift . getRandomR - getRandoms = lift getRandoms - getRandomRs = lift . getRandomRs - diff --git a/src/Kucipong/Orphans.hs b/src/Kucipong/Orphans.hs index 9db2bd6..6c281c3 100644 --- a/src/Kucipong/Orphans.hs +++ b/src/Kucipong/Orphans.hs @@ -10,3 +10,22 @@ other libraries but that we use here. -} module Kucipong.Orphans where + +import ClassyPrelude + +import Control.Monad.Logger ( LoggingT, MonadLogger ) +import Control.Monad.Random ( MonadRandom(..) ) +import Language.Haskell.TH ( Q, runIO ) +import Web.Spock ( ActionCtxT ) + +instance MonadRandom m => MonadRandom (LoggingT m) where + getRandom = lift getRandom + getRandomR = lift . getRandomR + getRandoms = lift getRandoms + getRandomRs = lift . getRandomRs + +instance MonadLogger m => MonadLogger (ActionCtxT ctx m) + +instance MonadIO Q where + liftIO :: IO a -> Q a + liftIO = runIO diff --git a/src/Kucipong/Prelude.hs b/src/Kucipong/Prelude.hs index 58ca822..8ed96b0 100644 --- a/src/Kucipong/Prelude.hs +++ b/src/Kucipong/Prelude.hs @@ -5,7 +5,7 @@ import ClassyPrelude as X import Control.Monad.Base as X ( MonadBase(..) ) import Control.Monad.Except as X ( ExceptT(..), MonadError(..), runExceptT ) -import Control.Monad.Logger as X ( LoggingT, MonadLogger ) +import Control.Monad.Logger as X ( LoggingT, MonadLogger, logDebug ) import Control.Monad.Reader as X ( reader ) import Control.Monad.Trans.Control as X ( MonadBaseControl ) import Control.Monad.Trans.Identity as X ( IdentityT(..), runIdentityT ) @@ -14,4 +14,7 @@ import Data.Proxy as X ( Proxy(Proxy) ) import Data.Word as X ( Word16 ) import "emailaddress" Text.Email.Validate as X ( EmailAddress ) +-- Orphan instances + import Kucipong.Orphans as X () +import Instances.TH.Lift as X () diff --git a/src/Kucipong/RenderTemplate.hs b/src/Kucipong/RenderTemplate.hs new file mode 100644 index 0000000..cd60ea5 --- /dev/null +++ b/src/Kucipong/RenderTemplate.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Kucipong.RenderTemplate where + +import Kucipong.Prelude hiding ( try ) + +import Control.Exception ( try ) +import Language.Haskell.TH + ( Exp, Q, appE, litE, lookupValueName, mkName, stringL, varE ) +import Language.Haskell.TH.Syntax ( addDependentFile ) +import Network.HTTP.Types ( internalServerError500 ) +import Text.EDE ( Template, eitherParse, eitherRender, fromPairs ) +import Web.Spock ( html, setStatus ) + +import Kucipong.Util ( fromEitherM ) + +templateDirectory :: FilePath +templateDirectory = "frontend" "dist" + +unsafeFromRight :: Show e => Either e a -> a +unsafeFromRight (Right a) = a +unsafeFromRight (Left err) = error $ + "Called unsafeFromRight, but we got a left with this value: " <> show err + +renderTemplateFromEnv :: String -> Q Exp +renderTemplateFromEnv filename = do + addDependentFile fullFilePath + eitherRawTemplate <- liftIO . try $ readFile fullFilePath + rawTemplate <- fromEitherM handleTemplateFileRead eitherRawTemplate + let eitherParsedTemplate = eitherParse rawTemplate + -- Check to make sure the template can be parsed correctly. Return an + -- error during compile time to the user if it cannot. + void $ fromEitherM handleIncorrectTemplate eitherParsedTemplate + templateExp <- [e| unsafeFromRight $ eitherParse rawTemplate |] + eitherRenderLambdaExp <- [e| eitherRender $(pure templateExp) |] + [e| \environmentObject -> case $(pure eitherRenderLambdaExp) environmentObject of + Left err -> do + setStatus internalServerError500 + html $ "

Error with rendering template:

" <> pack err + Right bytestring -> html $ toStrict bytestring |] + where + -- This is the full path of the template file. + fullFilePath :: FilePath + fullFilePath = templateDirectory filename + + handleTemplateFileRead :: SomeException -> Q a + handleTemplateFileRead exception = fail $ + "exception occured when trying to read the template file \"" <> + fullFilePath <> + ":\n" <> + show exception + + handleIncorrectTemplate :: String -> Q a + handleIncorrectTemplate errorMsg = fail $ + "exception occured when trying to parse the template file \"" <> + fullFilePath <> ":\n" <> errorMsg diff --git a/test/DocTest.hs b/test/DocTest.hs index 862747f..2459282 100644 --- a/test/DocTest.hs +++ b/test/DocTest.hs @@ -14,7 +14,8 @@ doDocTest options = doctest $ options <> ghcExtensions ghcExtensions :: [String] ghcExtensions = - [ "-XConstraintKinds" + [ "-XBangPatterns" + , "-XConstraintKinds" , "-XDataKinds" , "-XDeriveDataTypeable" , "-XDeriveFunctor"