_{MsgErrorResponseEncrypted} +
+ #{formatted}
+ |]
+
+ errPage = case err of
+ NotFound -> [whamlet|_{MsgErrorResponseNotFound}|]
+ InternalError err -> encrypted err [whamlet|
#{err}|]
+ InvalidArgs errs -> [whamlet|
+
_{MsgErrorResponseNotAuthenticated}|] + PermissionDenied err -> [whamlet|
#{err}|] + BadMethod method -> [whamlet|
_{MsgErrorResponseBadMethod (decodeUtf8 method)}|] + fmap toTypedContent . siteLayout (Just . toHtml . mr $ ErrorResponseTitle err) $ do + toWidget + [cassius| + .errMsg + white-space: pre-wrap + font-family: monospace + |] + errPage - mcurrentRoute <- getCurrentRoute - - -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. - (title, parents) <- breadcrumbs - --- let isParent :: Route UniWorX -> Bool --- isParent r = r == (fst parents) - - let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute - - menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu - - isAuth <- isJust <$> maybeAuthId - - -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! - (favourites', currentTheme) <- do - muid <- maybeAuthPair - case muid of - Nothing -> return ([],userDefaultTheme) - (Just (uid,user)) -> do - favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do - E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) - E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) - E.orderBy [ E.asc $ course E.^. CourseShorthand ] - return course - return (favs, userTheme user) - favourites <- forM favourites' $ \(Entity _ c@Course{..}) - -> let - courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR - in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) - - let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority - highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents - navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes - highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs - in \r -> Just r == highR - favouriteTerms :: [TermIdentifier] - favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites - favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])] - favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites - - -- We break up the default layout into two components: - -- default-layout is the contents of the body tag, and - -- default-layout-wrapper is the entire page. Since the final - -- value passed to hamletToRepHtml cannot be a widget, this allows - -- you to use normal widget features in default-layout. - - - let - navbar :: Widget - navbar = $(widgetFile "widgets/navbar") - asidenav :: Widget - asidenav = $(widgetFile "widgets/asidenav") - contentHeadline :: Maybe Widget - contentHeadline = pageHeading =<< mcurrentRoute - breadcrumbs :: Widget - breadcrumbs = $(widgetFile "widgets/breadcrumbs") - pageactionprime :: Widget - pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now - -- functions to determine if there are page-actions (primary or secondary) - isPageActionPrime :: MenuTypes -> Bool - isPageActionPrime (PageActionPrime _) = True - isPageActionPrime (PageActionSecondary _) = True - isPageActionPrime _ = False - hasPageActions :: Bool - hasPageActions = any (isPageActionPrime . fst) menuTypes - - pc <- widgetToPageContent $ do - addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" - addScript $ StaticR js_zepto_js - addScript $ StaticR js_fetchPolyfill_js - addScript $ StaticR js_urlPolyfill_js - addScript $ StaticR js_featureChecker_js - addScript $ StaticR js_flatpickr_js - addScript $ StaticR js_tabber_js - addStylesheet $ StaticR css_flatpickr_css - addStylesheet $ StaticR css_tabber_css - addStylesheet $ StaticR css_fonts_css - addStylesheet $ StaticR css_fontawesome_css - $(widgetFile "default-layout") - $(widgetFile "standalone/modal") - $(widgetFile "standalone/showHide") - $(widgetFile "standalone/inputs") - $(widgetFile "standalone/tooltip") - $(widgetFile "standalone/tabber") - $(widgetFile "standalone/alerts") - $(widgetFile "standalone/datepicker") - withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + defaultLayout = siteLayout Nothing -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR @@ -768,6 +691,105 @@ instance Yesod UniWorX where makeLogger = return . appLogger +siteLayout :: Maybe Html -- ^ Optionally override `pageHeading` + -> Widget -> Handler Html +siteLayout headingOverride widget = do + master <- getYesod + let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + + applySystemMessages + mmsgs <- getMessages + + mcurrentRoute <- getCurrentRoute + + -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. + (title, parents) <- breadcrumbs + + -- let isParent :: Route UniWorX -> Bool + -- isParent r = r == (fst parents) + + let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute + + menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu + + isAuth <- isJust <$> maybeAuthId + + -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! + (favourites', currentTheme) <- do + muid <- maybeAuthPair + case muid of + Nothing -> return ([],userDefaultTheme) + (Just (uid,user)) -> do + favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do + E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) + E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid) + E.orderBy [ E.asc $ course E.^. CourseShorthand ] + return course + return (favs, userTheme user) + favourites <- forM favourites' $ \(Entity _ c@Course{..}) + -> let + courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR + in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) + + let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority + highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents + navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes + highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs + in \r -> Just r == highR + favouriteTerms :: [TermIdentifier] + favouriteTerms = Set.toDescList $ foldMap (\(Course{..}, _, _) -> Set.singleton $ unTermKey courseTerm) favourites + favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [MenuTypes])] + favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites + + -- We break up the default layout into two components: + -- default-layout is the contents of the body tag, and + -- default-layout-wrapper is the entire page. Since the final + -- value passed to hamletToRepHtml cannot be a widget, this allows + -- you to use normal widget features in default-layout. + + + let + navbar :: Widget + navbar = $(widgetFile "widgets/navbar") + asidenav :: Widget + asidenav = $(widgetFile "widgets/asidenav") + contentHeadline :: Maybe Widget + contentHeadline = (toWidget <$> headingOverride) <|> (pageHeading =<< mcurrentRoute) + breadcrumbs :: Widget + breadcrumbs = $(widgetFile "widgets/breadcrumbs") + pageactionprime :: Widget + pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now + -- functions to determine if there are page-actions (primary or secondary) + isPageActionPrime :: MenuTypes -> Bool + isPageActionPrime (PageActionPrime _) = True + isPageActionPrime (PageActionSecondary _) = True + isPageActionPrime _ = False + hasPageActions :: Bool + hasPageActions = any (isPageActionPrime . fst) menuTypes + + pc <- widgetToPageContent $ do + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600" + addScript $ StaticR js_zepto_js + addScript $ StaticR js_fetchPolyfill_js + addScript $ StaticR js_urlPolyfill_js + addScript $ StaticR js_featureChecker_js + addScript $ StaticR js_flatpickr_js + addScript $ StaticR js_tabber_js + addStylesheet $ StaticR css_flatpickr_css + addStylesheet $ StaticR css_tabber_css + addStylesheet $ StaticR css_fonts_css + addStylesheet $ StaticR css_fontawesome_css + $(widgetFile "default-layout") + $(widgetFile "standalone/modal") + $(widgetFile "standalone/showHide") + $(widgetFile "standalone/inputs") + $(widgetFile "standalone/tooltip") + $(widgetFile "standalone/tabber") + $(widgetFile "standalone/alerts") + $(widgetFile "standalone/datepicker") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m () applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage where diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index c0660967a..458e3d766 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -279,10 +279,8 @@ helpForm mReferer mUid = HelpForm , (HIAnonymous, pure $ Left Nothing) ] -getHelpR :: Handler Html +getHelpR, postHelpR :: Handler Html getHelpR = postHelpR - -postHelpR :: Handler Html postHelpR = do mUid <- maybeAuthId mRefererBS <- requestHeaderReferer <$> waiRequest diff --git a/src/Model.hs b/src/Model.hs index 76a543723..bd56ab5a2 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,6 +33,7 @@ import Data.CaseInsensitive (CI) import Data.CaseInsensitive.Instances () import Utils.Message (MessageClass) +import Settings.Cluster (ClusterSettingsKey) -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities diff --git a/src/Settings.hs b/src/Settings.hs index c246311a7..da5fc9336 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -7,6 +7,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Settings are centralized, as much as possible, into this file. This @@ -14,12 +17,17 @@ -- In addition, you can configure a number of different aspects of Yesod -- by overriding methods in the Yesod typeclass. That instance is -- declared in the Foundation.hs file. -module Settings where +module Settings + ( module Settings + , module Settings.Cluster + ) where -import ClassyPrelude.Yesod +import ClassyPrelude.Yesod hiding (Proxy) +import Data.UUID (UUID) import qualified Control.Exception as Exception -import Data.Aeson (Result (..), fromJSON, withObject, - (.!=), (.:?), withScientific) +import Data.Aeson (Result (..), fromJSON, withObject + ,(.!=), (.:?), withScientific + ) import qualified Data.Aeson.Types as Aeson import Data.Aeson.TH import Data.FileEmbed (embedFile) @@ -57,6 +65,7 @@ import Network.Mail.Mime (Address) import Mail (VerpMode) import Model +import Settings.Cluster -- | Runtime settings to configure this application. These settings can be -- loaded from various sources: defaults, environment variables, config files, @@ -91,6 +100,7 @@ data AppSettings = AppSettings , appNotificationRateLimit :: NominalDiffTime , appNotificationCollateDelay :: NominalDiffTime , appNotificationExpiration :: NominalDiffTime + , appSessionTimeout :: NominalDiffTime , appInitialLogSettings :: LogSettings @@ -104,12 +114,12 @@ data AppSettings = AppSettings -- ^ Indicate if auth dummy login should be enabled. , appAllowDeprecated :: Bool -- ^ Indicate if deprecated routes are accessible for everyone + , appEncryptErrors :: Bool , appUserDefaults :: UserDefaultConf , appAuthPWHash :: PWHashConf - , appCryptoIDKeyFile :: FilePath - , appInstanceIDFile :: Maybe FilePath + , appInitialInstanceID :: Maybe (Either FilePath UUID) } deriving (Show) data LogSettings = LogSettings @@ -264,7 +274,6 @@ deriveFromJSON ''Address - instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -298,19 +307,21 @@ instance FromJSON AppSettings where appNotificationCollateDelay <- o .: "notification-collate-delay" appNotificationExpiration <- o .: "notification-expiration" + appSessionTimeout <- o .: "session-timeout" + appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appMutableStatic <- o .:? "mutable-static" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev + appEncryptErrors <- o .:? "encrypt-errors" .!= not defaultDev appInitialLogSettings <- o .: "log-settings" appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" - appCryptoIDKeyFile <- o .: "cryptoid-keyfile" - appInstanceIDFile <- o .:? "instance-idfile" + appInitialInstanceID <- (o .:? "instance-id") >>= maybe (return Nothing) (\v -> Just <$> ((Right <$> parseJSON v) <|> (Left <$> parseJSON v))) return AppSettings {..} diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs new file mode 100644 index 000000000..94bce92e0 --- /dev/null +++ b/src/Settings/Cluster.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE NoImplicitPrelude + , DataKinds + , TypeFamilies + , ScopedTypeVariables + , TemplateHaskell + , OverloadedStrings + , FlexibleContexts + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Settings.Cluster + ( ClusterSettingsKey(..) + , ClusterSetting(..) + ) where + +import ClassyPrelude.Yesod +import Database.Persist.Sql +import Web.HttpApiData + +import Utils +import Control.Lens +import Data.Universe + +import Data.Aeson ( FromJSON(..), ToJSON(..) + , Options(..), defaultOptions + , FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..) + ) +import Data.Aeson.TH (deriveJSON) +import Data.Aeson.Types (toJSONKeyText) +import qualified Data.Aeson as Aeson + +import qualified Web.ClientSession as ClientSession +import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Crypto.Saltine.Class as Saltine + +import Data.CryptoID.ByteString (CryptoIDKey) +import qualified Data.CryptoID.ByteString as CryptoID + +import qualified Data.Binary as Binary +import qualified Data.Serialize as Serialize +import qualified Data.ByteString.Base64.URL as Base64 + + +data ClusterSettingsKey + = ClusterCryptoIDKey + | ClusterClientSessionKey + | ClusterErrorMessageKey + deriving (Eq, Ord, Enum, Bounded, Show, Read) + +instance Universe ClusterSettingsKey +instance Finite ClusterSettingsKey + +$(return []) + +instance PathPiece ClusterSettingsKey where + toPathPiece = $(nullaryToPathPiece ''ClusterSettingsKey [intercalate "-" . map toLower . drop 1 . splitCamel]) + fromPathPiece = finiteFromPathPiece + +deriveJSON + defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } + ''ClusterSettingsKey + +instance ToJSONKey ClusterSettingsKey where + toJSONKey = toJSONKeyText $ \v -> let String t = toJSON v in t + +instance FromJSONKey ClusterSettingsKey where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . String + +instance PersistField ClusterSettingsKey where + toPersistValue = PersistText . toPathPiece + fromPersistValue (PersistText t) = maybe (Left $ "Could not parse " <> t) Right $ fromPathPiece t + fromPersistValue _other = Left "Expecting PersistText" + +instance PersistFieldSql ClusterSettingsKey where + sqlType _ = SqlString + +instance ToHttpApiData ClusterSettingsKey where + toUrlPiece = toPathPiece +instance FromHttpApiData ClusterSettingsKey where + parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece + + +class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where + type ClusterSettingValue key :: * + initClusterSetting :: forall m p. MonadIO m => p key -> m (ClusterSettingValue key) + knownClusterSetting :: forall p. p key -> ClusterSettingsKey + + +instance ClusterSetting 'ClusterCryptoIDKey where + type ClusterSettingValue 'ClusterCryptoIDKey = CryptoIDKey + initClusterSetting _ = CryptoID.genKey + knownClusterSetting _ = ClusterCryptoIDKey + +instance ToJSON CryptoIDKey where + toJSON = Aeson.String . decodeUtf8 . Base64.encode . toStrict . Binary.encode + +instance FromJSON CryptoIDKey where + parseJSON = Aeson.withText "CryptoIDKey" $ \t -> do + bytes <- either fail (return . fromStrict) . Base64.decode $ encodeUtf8 t + case Binary.decodeOrFail bytes of + Left (_, _, err) -> fail err + Right (bs, _, ret) + | null bs -> return ret + | otherwise -> fail $ show (length bs) ++ " extra bytes" + + +instance ClusterSetting 'ClusterClientSessionKey where + type ClusterSettingValue 'ClusterClientSessionKey = ClientSession.Key + initClusterSetting _ = liftIO $ view _2 <$> ClientSession.randomKey + knownClusterSetting _ = ClusterClientSessionKey + +instance ToJSON ClientSession.Key where + toJSON = Aeson.String . decodeUtf8 . Base64.encode . Serialize.encode + +instance FromJSON ClientSession.Key where + parseJSON = Aeson.withText "Key" $ \t -> do + bytes <- either fail return . Base64.decode $ encodeUtf8 t + either fail return $ Serialize.decode bytes + + +instance ClusterSetting 'ClusterErrorMessageKey where + type ClusterSettingValue 'ClusterErrorMessageKey = SecretBox.Key + initClusterSetting _ = liftIO $ SecretBox.newKey + knownClusterSetting _ = ClusterErrorMessageKey + +instance ToJSON SecretBox.Key where + toJSON = Aeson.String . decodeUtf8 . Base64.encode . Saltine.encode + +instance FromJSON SecretBox.Key where + parseJSON = Aeson.withText "Key" $ \t -> do + bytes <- either fail return . Base64.decode $ encodeUtf8 t + maybe (fail "Could not parse key") return $ Saltine.decode bytes diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 3f5579269..c2d050bde 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -1,19 +1,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Utils.TH where -- Common Utility Functions that require TemplateHaskell -- import Data.Char -import Prelude +import ClassyPrelude.Yesod import Language.Haskell.TH +import Language.Haskell.TH.Datatype -- import Control.Monad -- import Control.Monad.Trans.Class -- import Control.Monad.Trans.Maybe -- import Control.Monad.Trans.Except +import Data.List ((!!), foldl) + ------------ -- Tuples -- ------------ @@ -45,7 +50,7 @@ altFun perm = lamE pat rhs where pat = map varP $ fn:xs rhs = foldl appE (varE fn) $ map varE ps -- rhs = appE (varE fn) (varE $ xs!!1) - mx = maximum perm + mx = maximum $ impureNonNull perm xs = [ mkName $ "x" ++ show j | j <- [1..mx] ] ps = [ xs !! (j-1) | j <- perm ] fn = mkName "fn" @@ -78,3 +83,62 @@ deriveSimpleWith cls fun strOp ty = do in return $ Clause pats body [] genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments" +embedRenderMessage :: Name -- ^ Foundation type + -> Name -- ^ Type to embed into message type + -> (Text -> Text) -- ^ Mangle constructor names + -> DecsQ +-- ^ @embedRenderMessage ''Foundation ''MessageType mangle@ declares a +-- `RenderMessage Foundation MessageType` instance expecting the default +-- message-datatype (@FoundationMessage@) to contain one constructor for each +-- constructor of @MessageType@, taking the same arguments: +-- +-- > data NewMessage = NewMessageOne | NewMessageTwo +-- > data FoundationMessage = MsgOne | MsgTwo +-- > +-- > -- embedRenderMessage ''Foundation ''NewMessage (drop 2 . splitCamel) +-- > instance RenderMessage Foundation NewMessage where +-- > renderMessage f ls = renderMessage f ls . \case +-- > NewMessageOne -> MsgOne +-- > NewMessageTwo -> MsgTwo +embedRenderMessage f inner mangle = do + DatatypeInfo{..} <- reifyDatatype inner + let + matches :: [MatchQ] + matches = flip map datatypeCons $ \ConstructorInfo{..} -> do + vars <- forM constructorFields $ \_ -> newName "x" + let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars + match (conP constructorName $ map varP vars) (normalB body) [] + + f' <- newName "f" + ls <- newName "ls" + + pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT inner)|] + [ funD 'renderMessage + [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] + ] + ] + +embedRenderMessageVariant :: Name -- ^ Foundation Type + -> Name -- ^ Name of newtype + -> (Text -> Text) -- ^ Mangle constructor names + -> DecsQ +embedRenderMessageVariant f newT mangle = do + [ConstructorInfo{ constructorName = newtypeName, constructorFields = [ ConT newtypeInner ] }] <- datatypeCons <$> reifyDatatype newT + DatatypeInfo{..} <- reifyDatatype newtypeInner + + let + matches :: [MatchQ] + matches = flip map datatypeCons $ \ConstructorInfo{..} -> do + vars <- forM constructorFields $ \_ -> newName "x" + let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars + match (conP newtypeName [conP constructorName $ map varP vars]) (normalB body) [] + + f' <- newName "f" + ls <- newName "ls" + + pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT newT)|] + [ funD 'renderMessage + [ clause [varP f', varP ls] (normalB $ [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) [] + ] + ] + diff --git a/stack.nix b/stack.nix index 93d072683..971fbc175 100644 --- a/stack.nix +++ b/stack.nix @@ -7,7 +7,7 @@ in haskell.lib.buildStackProject { inherit ghc; name = "stackenv"; buildInputs = (with pkgs; - [ postgresql zlib openldap cyrus_sasl.dev + [ postgresql zlib openldap cyrus_sasl.dev libsodium ]) ++ (with haskellPackages; [ yesod-bin ]); diff --git a/stack.yaml b/stack.yaml index 8f93444f8..2551d1ab6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -36,4 +36,6 @@ extra-deps: - persistent-2.7.3.1 + - saltine-0.1.0.1 + resolver: lts-10.5 diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet index 788577105..63ecb972a 100644 --- a/templates/default-layout.hamlet +++ b/templates/default-layout.hamlet @@ -14,13 +14,11 @@