From 59e14ce390856825b859413ed91e82b5a952bdc8 Mon Sep 17 00:00:00 2001 From: Stuce Date: Sat, 7 Jun 2025 16:04:51 +0100 Subject: [PATCH] version 1 done --- .dir-locals.el | 4 + .gitattributes | 1 + .gitignore | 22 + README.md | 43 + app/DevelMain.hs | 105 + app/devel.hs | 6 + app/main.hs | 5 + config/favicon.ico | Bin 0 -> 1342 bytes config/keter.yml | 73 + config/models.persistentmodels | 20 + config/robots.txt | 1 + config/routes.yesodroutes | 25 + config/settings.yml | 40 + config/test-settings.yml | 11 + package.yaml | 100 + src/Application.hs | 189 + src/Foundation.hs | 193 + src/Handler/Common.hs | 22 + src/Handler/Home.hs | 41 + src/Handler/TodoEntry.hs | 249 + src/Import.hs | 6 + src/Import/NoFoundation.hs | 11 + src/Model.hs | 25 + src/Settings.hs | 148 + src/Settings/StaticFiles.hs | 39 + stack.yaml | 67 + stack.yaml.lock | 13 + static/css/bootstrap.css | 7022 +++++++++++++++++ static/fonts/glyphicons-halflings-regular.eot | Bin 0 -> 20335 bytes static/fonts/glyphicons-halflings-regular.svg | 229 + static/fonts/glyphicons-halflings-regular.ttf | Bin 0 -> 41280 bytes .../fonts/glyphicons-halflings-regular.woff | Bin 0 -> 23320 bytes templates/default-layout-wrapper.hamlet | 14 + templates/default-layout.hamlet | 11 + templates/default-layout.lucius | 0 templates/homepage.hamlet | 141 + templates/homepage.julius | 34 + templates/homepage.lucius | 13 + templates/profile.hamlet | 10 + test/Handler/CommentSpec.hs | 47 + test/Handler/CommonSpec.hs | 17 + test/Handler/EditSpec.hs | 14 + test/Handler/HomeSpec.hs | 35 + test/Handler/ProfileSpec.hs | 28 + test/Handler/TodoEntrySpec.hs | 10 + test/Spec.hs | 1 + test/TestImport.hs | 103 + 47 files changed, 9188 insertions(+) create mode 100644 .dir-locals.el create mode 100644 .gitattributes create mode 100644 .gitignore create mode 100644 README.md create mode 100644 app/DevelMain.hs create mode 100644 app/devel.hs create mode 100644 app/main.hs create mode 100644 config/favicon.ico create mode 100644 config/keter.yml create mode 100644 config/models.persistentmodels create mode 100644 config/robots.txt create mode 100644 config/routes.yesodroutes create mode 100644 config/settings.yml create mode 100644 config/test-settings.yml create mode 100644 package.yaml create mode 100644 src/Application.hs create mode 100644 src/Foundation.hs create mode 100644 src/Handler/Common.hs create mode 100644 src/Handler/Home.hs create mode 100644 src/Handler/TodoEntry.hs create mode 100644 src/Import.hs create mode 100644 src/Import/NoFoundation.hs create mode 100644 src/Model.hs create mode 100644 src/Settings.hs create mode 100644 src/Settings/StaticFiles.hs create mode 100644 stack.yaml create mode 100644 stack.yaml.lock create mode 100644 static/css/bootstrap.css create mode 100644 static/fonts/glyphicons-halflings-regular.eot create mode 100644 static/fonts/glyphicons-halflings-regular.svg create mode 100644 static/fonts/glyphicons-halflings-regular.ttf create mode 100644 static/fonts/glyphicons-halflings-regular.woff create mode 100644 templates/default-layout-wrapper.hamlet create mode 100644 templates/default-layout.hamlet create mode 100644 templates/default-layout.lucius create mode 100644 templates/homepage.hamlet create mode 100644 templates/homepage.julius create mode 100644 templates/homepage.lucius create mode 100644 templates/profile.hamlet create mode 100644 test/Handler/CommentSpec.hs create mode 100644 test/Handler/CommonSpec.hs create mode 100644 test/Handler/EditSpec.hs create mode 100644 test/Handler/HomeSpec.hs create mode 100644 test/Handler/ProfileSpec.hs create mode 100644 test/Handler/TodoEntrySpec.hs create mode 100644 test/Spec.hs create mode 100644 test/TestImport.hs diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..a44395f --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,4 @@ +((haskell-mode . ((haskell-indent-spaces . 4) + (haskell-process-use-ghci . t))) + (hamlet-mode . ((hamlet/basic-offset . 4) + (haskell-process-use-ghci . t)))) diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 0000000..6313b56 --- /dev/null +++ b/.gitattributes @@ -0,0 +1 @@ +* text=auto eol=lf diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..dd48cb4 --- /dev/null +++ b/.gitignore @@ -0,0 +1,22 @@ +dist* +static/tmp/ +static/combined/ +config/client_session_key.aes +*.hi +*.o +*.sqlite3 +*.sqlite3-shm +*.sqlite3-wal +.hsenv* +cabal-dev/ +.stack-work/ +.stack-work-devel/ +yesod-devel/ +.cabal-sandbox +cabal.sandbox.config +.DS_Store +*.swp +*.keter +*~ +\#* +sTodo.cabal diff --git a/README.md b/README.md new file mode 100644 index 0000000..3f6f7d9 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +## Haskell Setup + +1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) + * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh` +2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc` +3. Build libraries: `stack build` + +If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail. + +## Development + +Start a development server with: + +``` +stack exec -- yesod devel +``` + +As your code changes, your site will be automatically recompiled and redeployed to localhost. + +## Tests + +``` +stack test --flag sTodo:library-only --flag sTodo:dev +``` + +(Because `yesod devel` passes the `library-only` and `dev` flags, matching those flags means you don't need to recompile between tests and development, and it disables optimization to speed up your test compile times). + +## Documentation + +* Read the [Yesod Book](https://www.yesodweb.com/book) online for free +* Check [Stackage](http://stackage.org/) for documentation on the packages in your LTS Haskell version, or [search it using Hoogle](https://www.stackage.org/lts/hoogle?q=). Tip: Your LTS version is in your `stack.yaml` file. +* For local documentation, use: + * `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser + * `stack hoogle ` to generate a Hoogle database and search for your query +* The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs + +## Getting Help + +* Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell) +* Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb) +* There are several chatrooms you can ask for help: + * For IRC, try Freenode#yesod and Freenode#haskell + * [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels. diff --git a/app/DevelMain.hs b/app/DevelMain.hs new file mode 100644 index 0000000..7d2e9b2 --- /dev/null +++ b/app/DevelMain.hs @@ -0,0 +1,105 @@ +-- | Running your app inside GHCi. +-- +-- This option provides significantly faster code reload compared to +-- @yesod devel@. However, you do not get automatic code reload +-- (which may be a benefit, depending on your perspective). To use this: +-- +-- 1. Start up GHCi +-- +-- $ stack ghci sTodo:lib --no-load --work-dir .stack-work-devel +-- +-- 2. Load this module +-- +-- > :l app/DevelMain.hs +-- +-- 3. Run @update@ +-- +-- > DevelMain.update +-- +-- 4. Your app should now be running, you can connect at http://localhost:3000 +-- +-- 5. Make changes to your code +-- +-- 6. After saving your changes, reload by running: +-- +-- > :r +-- > DevelMain.update +-- +-- You can also call @DevelMain.shutdown@ to stop the app +-- +-- There is more information about this approach, +-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci +-- +-- WARNING: GHCi does not notice changes made to your template files. +-- If you change a template, you'll need to either exit GHCi and reload, +-- or manually @touch@ another Haskell module. + +module DevelMain where + +import Prelude +import Application (getApplicationRepl, shutdownApp) + +import Control.Monad ((>=>)) +import Control.Concurrent +import Data.IORef +import Foreign.Store +import Network.Wai.Handler.Warp +import GHC.Word + +-- | Start or restart the server. +-- newStore is from foreign-store. +-- A Store holds onto some data across ghci reloads +update :: IO () +update = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> do + done <- storeAction doneStore newEmptyMVar + tid <- start done + _ <- storeAction (Store tidStoreNum) (newIORef tid) + return () + -- server is already running + Just tidStore -> restartAppInNewThread tidStore + where + doneStore :: Store (MVar ()) + doneStore = Store 0 + + -- shut the server down with killThread and wait for the done signal + restartAppInNewThread :: Store (IORef ThreadId) -> IO () + restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do + killThread tid + withStore doneStore takeMVar + readStore doneStore >>= start + + + -- | Start the server in a separate thread. + start :: MVar () -- ^ Written to when the thread is killed. + -> IO ThreadId + start done = do + (port, site, app) <- getApplicationRepl + forkFinally + (runSettings (setPort port defaultSettings) app) + -- Note that this implies concurrency + -- between shutdownApp and the next app that is starting. + -- Normally this should be fine + (\_ -> putMVar done () >> shutdownApp site) + +-- | kill the server +shutdown :: IO () +shutdown = do + mtidStore <- lookupStore tidStoreNum + case mtidStore of + -- no server running + Nothing -> putStrLn "no Yesod app running" + Just tidStore -> do + withStore tidStore $ readIORef >=> killThread + putStrLn "Yesod app is shutdown" + +tidStoreNum :: Word32 +tidStoreNum = 1 + +modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () +modifyStoredIORef store f = withStore store $ \ref -> do + v <- readIORef ref + f v >>= writeIORef ref diff --git a/app/devel.hs b/app/devel.hs new file mode 100644 index 0000000..bbc3040 --- /dev/null +++ b/app/devel.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE PackageImports #-} +import "sTodo" Application (develMain) +import Prelude (IO) + +main :: IO () +main = develMain diff --git a/app/main.hs b/app/main.hs new file mode 100644 index 0000000..4ffa93d --- /dev/null +++ b/app/main.hs @@ -0,0 +1,5 @@ +import Prelude (IO) +import Application (appMain) + +main :: IO () +main = appMain diff --git a/config/favicon.ico b/config/favicon.ico new file mode 100644 index 0000000000000000000000000000000000000000..9dd5f356d4119b9f50f2cfc370d84b975688ca3f GIT binary patch literal 1342 zcmZQzU}Ruo5D);-3Je)63=C=v3=9GSObm<+j0_tX7#R9k7#K7_Vhjun3Jef+3^>5D zI2~jeMn_F))n-lUQe@!lq{ok7#{OiVkpDfI!T)Y*;sO{xAD@9{RX+|cPUIPhsrXWM#oK3QRUDX-IQLW{RGRFk(kOoQ`5j27p=7%i^<&hl&l2?l~^ zZG;*4eKiD<+r!Ntou6B?w>jMMVYQF$>yy*V_D@c6xtnGw^*_yA@_(9z)cHis4 zGXK*prT&;munI=%3Ye-1FsM}c=wCfKt>nIbVZ2G)!wY2|D9?6 z|3K*!l5T_lf#~jxpnu(&LH~NQL;m$;hyLr&4gX&gW;-X@N{$U=KN}MRL%O?>L2HWN zty$IS|7TXE{hwKx`fp}c8VLWNRh9OCR(1NnSv8p;`hRW!B zFmG-{?*HXI)&G}uSN&hsQw3(P=&kubyDsZ=4.9.1.0 && <5 +- yesod >=1.6 && <1.7 +- yesod-core >=1.6 && <1.7 +- yesod-auth >=1.6 && <1.7 +- yesod-static >=1.6 && <1.7 +- yesod-form >=1.6 && <1.8 +- classy-prelude >=1.5 && <1.6 +- classy-prelude-conduit >=1.5 && <1.6 +- classy-prelude-yesod >=1.5 && <1.6 +- bytestring >=0.10 && <0.12 +- text >=0.11 && <2.0 +- persistent >=2.9 && <2.14 +- persistent-sqlite >=2.9 && <2.14 +- persistent-template >=2.5 && <2.14 +- template-haskell +- shakespeare >=2.0 && <2.1 +- hjsmin >=0.1 && <0.3 +- monad-control >=0.3 && <1.1 +- wai-extra >=3.0 && <3.2 +- yaml >=0.11 && <0.12 +- http-client-tls >=0.3 && <0.4 +- http-conduit >=2.3 && <2.4 +- directory >=1.1 && <1.4 +- warp >=3.0 && <3.4 +- data-default +- aeson >=1.4 && <2.1 +- conduit >=1.0 && <2.0 +- monad-logger >=0.3 && <0.4 +- fast-logger >=2.2 && <3.2 +- wai-logger >=2.2 && <2.5 +- file-embed +- safe +- unordered-containers +- containers +- vector +- time +- case-insensitive +- wai +- foreign-store + +# The library contains all of our application code. The executable +# defined below is just a thin wrapper. +library: + source-dirs: src + when: + - condition: (flag(dev)) || (flag(library-only)) + then: + ghc-options: + - -Wall + - -fwarn-tabs + - -O0 + cpp-options: -DDEVELOPMENT + else: + ghc-options: + - -Wall + - -fwarn-tabs + - -O2 + +# Runnable executable for our application +executables: + sTodo: + main: main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - sTodo + when: + - condition: flag(library-only) + buildable: false + +# Test suite +tests: + sTodo-test: + main: Spec.hs + source-dirs: test + ghc-options: -Wall + dependencies: + - sTodo + - hspec >=2.0.0 + - yesod-test + - microlens + +# Define flags used by "yesod devel" to make compilation faster +flags: + library-only: + description: Build for use with "yesod devel" + manual: false + default: false + dev: + description: Turn on development settings, like auto-reload templates. + manual: false + default: false diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..cb03f37 --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application + ( getApplicationDev + , appMain + , develMain + , makeFoundation + , makeLogWare + -- * for DevelMain + , getApplicationRepl + , shutdownApp + -- * for GHCI + , handler + , db + ) where + +import Control.Monad.Logger (liftLoc, runLoggingT) +import Database.Persist.Sqlite (createSqlitePool, runSqlPool, + sqlDatabase, sqlPoolSize, rawExecute) +import Import +import Language.Haskell.TH.Syntax (qLocation) +import Network.HTTP.Client.TLS (getGlobalManager) +import Network.Wai (Middleware) +import Network.Wai.Handler.Warp (Settings, defaultSettings, + defaultShouldDisplayException, + runSettings, setHost, + setOnException, setPort, getPort) +import Network.Wai.Middleware.RequestLogger (Destination (Logger), + IPAddrSource (..), + OutputFormat (..), destination, + mkRequestLogger, outputFormat) +import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, + toLogStr) + +-- Import all relevant handler modules here. +-- Don't forget to add new modules to your cabal file! +import Handler.Common +import Handler.Home +import Handler.TodoEntry + +-- This line actually creates our YesodDispatch instance. It is the second half +-- of the call to mkYesodData which occurs in Foundation.hs. Please see the +-- comments there for more details. +mkYesodDispatch "App" resourcesApp + +-- | This function allocates resources (such as a database connection pool), +-- performs initialization and returns a foundation datatype value. This is also +-- the place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +makeFoundation :: AppSettings -> IO App +makeFoundation appSettings = do + -- Some basic initializations: HTTP connection manager, logger, and static + -- subsite. + appHttpManager <- getGlobalManager + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + appStatic <- + (if appMutableStatic appSettings then staticDevel else static) + (appStaticDir appSettings) + + -- We need a log function to create a connection pool. We need a connection + -- pool to create our foundation. And we need our foundation to get a + -- logging function. To get out of this loop, we initially create a + -- temporary foundation without a real connection pool, get a log function + -- from there, and then create the real foundation. + let mkFoundation appConnPool = App {..} + -- The App {..} syntax is an example of record wild cards. For more + -- information, see: + -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html + tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" + logFunc = messageLoggerSource tempFoundation appLogger + + -- Create the database connection pool + pool <- flip runLoggingT logFunc $ createSqlitePool + (sqlDatabase $ appDatabaseConf appSettings) + (sqlPoolSize $ appDatabaseConf appSettings) + -- Perform database migration using our application's logging settings. + runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc + _ <- runSqlPool (rawExecute "PRAGMA foreign_keys = ON;" []) pool + + -- Return the foundation + return $ mkFoundation pool + +-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and +-- applying some additional middlewares. +makeApplication :: App -> IO Application +makeApplication foundation = do + logWare <- makeLogWare foundation + -- Create the WAI application and apply middlewares + appPlain <- toWaiAppPlain foundation + return $ logWare $ defaultMiddlewaresNoLogging appPlain + +makeLogWare :: App -> IO Middleware +makeLogWare foundation = + mkRequestLogger def + { outputFormat = + if appDetailedRequestLogging $ appSettings foundation + then Detailed True + else Apache + (if appIpFromHeader $ appSettings foundation + then FromFallback + else FromSocket) + , destination = Logger $ loggerSet $ appLogger foundation + } + + +-- | Warp settings for the given foundation value. +warpSettings :: App -> Settings +warpSettings foundation = + setPort (appPort $ appSettings foundation) + $ setHost (appHost $ appSettings foundation) + $ setOnException (\_req e -> + when (defaultShouldDisplayException e) $ messageLoggerSource + foundation + (appLogger foundation) + $(qLocation >>= liftLoc) + "yesod" + LevelError + (toLogStr $ "Exception from Warp: " ++ show e)) + defaultSettings + +-- | For yesod devel, return the Warp settings and WAI Application. +getApplicationDev :: IO (Settings, Application) +getApplicationDev = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app <- makeApplication foundation + return (wsettings, app) + +getAppSettings :: IO AppSettings +getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv + +-- | main function for use by yesod devel +develMain :: IO () +develMain = develMainHelper getApplicationDev + +-- | The @main@ function for an executable running this site. +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + + -- allow environment variables to override + useEnv + + -- Generate the foundation from the settings + foundation <- makeFoundation settings + + -- Generate a WAI Application from the foundation + app <- makeApplication foundation + + -- Run the application with Warp + runSettings (warpSettings foundation) app + + +-------------------------------------------------------------- +-- Functions for DevelMain.hs (a way to run the app from GHCi) +-------------------------------------------------------------- +getApplicationRepl :: IO (Int, App, Application) +getApplicationRepl = do + settings <- getAppSettings + foundation <- makeFoundation settings + wsettings <- getDevSettings $ warpSettings foundation + app1 <- makeApplication foundation + return (getPort wsettings, foundation, app1) + +shutdownApp :: App -> IO () +shutdownApp _ = return () + + +--------------------------------------------- +-- Functions for use in development with GHCi +--------------------------------------------- + +-- | Run a handler +handler :: Handler a -> IO a +handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h + +-- | Run DB queries +db :: ReaderT SqlBackend Handler a -> IO a +db = handler . runDB diff --git a/src/Foundation.hs b/src/Foundation.hs new file mode 100644 index 0000000..241e246 --- /dev/null +++ b/src/Foundation.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} + +module Foundation where + +import Import.NoFoundation +import Data.Kind (Type) +import Database.Persist.Sql (ConnectionPool, runSqlPool) +import Text.Hamlet (hamletFile) +import Text.Jasmine (minifym) +import Control.Monad.Logger (LogSource) + +import Yesod.Default.Util (addStaticContentExternal) +import Yesod.Core.Types (Logger) +import qualified Yesod.Core.Unsafe as Unsafe +import qualified Data.CaseInsensitive as CI +import qualified Data.Text.Encoding as TE + +-- | The foundation datatype for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data App = App + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appHttpManager :: Manager + , appLogger :: Logger + } + +data MenuItem = MenuItem + { menuItemLabel :: Text + , menuItemRoute :: Route App + , menuItemAccessCallback :: Bool + } + +data MenuTypes + = NavbarLeft MenuItem + | NavbarRight MenuItem + +-- This is where we define all of the routes in our application. For a full +-- explanation of the syntax, please see: +-- http://www.yesodweb.com/book/routing-and-handlers +-- +-- Note that this is really half the story; in Application.hs, mkYesodDispatch +-- generates the rest of the code. Please see the following documentation +-- for an explanation for this split: +-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules +-- +-- This function also generates the following type synonyms: +-- type Handler = HandlerFor App +-- type Widget = WidgetFor App () +mkYesodData "App" $(parseRoutesFile "config/routes.yesodroutes") + +-- | A convenient synonym for creating forms. +type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) + +-- | A convenient synonym for database access functions. +type DB a = forall (m :: Type -> Type). + (MonadUnliftIO m) => ReaderT SqlBackend m a + +-- Please see the documentation for the Yesod typeclass. There are a number +-- of settings which can be configured by overriding methods here. +instance Yesod App where + -- Controls the base of generated URLs. For more information on modifying, + -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot + approot :: Approot App + approot = ApprootRequest $ \app req -> + case appRoot $ appSettings app of + Nothing -> getApprootText guessApproot app req + Just root -> root + + -- Store session data on the client in encrypted cookies, + -- default session idle timeout is 120 minutes + makeSessionBackend :: App -> IO (Maybe SessionBackend) + makeSessionBackend _ = Just <$> defaultClientSessionBackend + 120 -- timeout in minutes + "config/client_session_key.aes" + + -- Yesod Middleware allows you to run code before and after each handler function. + -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. + -- Some users may also want to add the defaultCsrfMiddleware, which: + -- a) Sets a cookie with a CSRF token in it. + -- b) Validates that incoming write requests include that token in either a header or POST parameter. + -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. + yesodMiddleware :: ToTypedContent res => Handler res -> Handler res + yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware + + defaultLayout :: Widget -> Handler Html + defaultLayout widget = do + master <- getYesod + mmsg <- getMessage + + mcurrentRoute <- getCurrentRoute + + -- 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. + + pc <- widgetToPageContent $ do + $(widgetFile "default-layout") + withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") + + isAuthorized + :: Route App -- ^ The route the user is visiting. + -> Bool -- ^ Whether or not this is a "write" request. + -> Handler AuthResult + -- Routes not requiring authentication. + -- TODO: check this bullshit if need to change it or not (prolly authelia problem) + isAuthorized _ _ = return Authorized + + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent + :: Text -- ^ The file extension + -> Text -- ^ The MIME content type + -> LByteString -- ^ The contents of the file + -> Handler (Maybe (Either Text (Route App, [(Text, Text)]))) + addStaticContent ext mime content = do + master <- getYesod + let staticDir = appStaticDir $ appSettings master + addStaticContentExternal + minifym + genFileName + staticDir + (StaticR . flip StaticRoute []) + ext + mime + content + where + -- Generate a unique filename based on the content itself + genFileName lbs = "autogen-" ++ base64md5 lbs + + -- What messages should be logged. The following includes all messages when + -- in development, and warnings and errors in production. + shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool + shouldLogIO app _source level = + return $ + appShouldLogAll (appSettings app) + || level == LevelWarn + || level == LevelError + + makeLogger :: App -> IO Logger + makeLogger = return . appLogger + +-- How to run database actions. +instance YesodPersist App where + type YesodPersistBackend App = SqlBackend + runDB :: SqlPersistT Handler a -> Handler a + runDB action = do + master <- getYesod + runSqlPool action $ appConnPool master + +instance YesodPersistRunner App where + getDBRunner :: Handler (DBRunner App, Handler ()) + getDBRunner = defaultGetDBRunner appConnPool + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage App FormMessage where + renderMessage :: App -> [Lang] -> FormMessage -> Text + renderMessage _ _ = defaultFormMessage + +-- Useful when writing code that is re-usable outside of the Handler context. +-- An example is background jobs that send email. +-- This can also be useful for writing code that works across multiple Yesod applications. +instance HasHttpManager App where + getHttpManager :: App -> Manager + getHttpManager = appHttpManager + +unsafeHandler :: App -> Handler a -> IO a +unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger + +-- Note: Some functionality previously present in the scaffolding has been +-- moved to documentation in the Wiki. Following are some hopefully helpful +-- links: +-- +-- https://github.com/yesodweb/yesod/wiki/Sending-email +-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain +-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding diff --git a/src/Handler/Common.hs b/src/Handler/Common.hs new file mode 100644 index 0000000..6783f8a --- /dev/null +++ b/src/Handler/Common.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +-- | Common handler functions. +module Handler.Common where + +import Data.FileEmbed (embedFile) +import Import + +-- These handlers embed files in the executable at compile time to avoid a +-- runtime dependency, and for efficiency. + +getFaviconR :: Handler TypedContent +getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month + return $ TypedContent "image/x-icon" + $ toContent $(embedFile "config/favicon.ico") + +getRobotsR :: Handler TypedContent +getRobotsR = return $ TypedContent typePlain + $ toContent $(embedFile "config/robots.txt") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs new file mode 100644 index 0000000..75b20a6 --- /dev/null +++ b/src/Handler/Home.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Handler.Home where + +import Import +import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) +import Text.Julius (RawJS (..)) + +-- Define our data that will be used for creating the form. +data FileForm = FileForm + { fileInfo :: FileInfo + , fileDescription :: Text + } + +-- This is a handler function for the GET request method on the HomeR +-- resource pattern. All of your resource patterns are defined in +-- config/routes.yesodroutes +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. + + +sampleForm :: Form FileForm +sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm + <$> fileAFormReq "Choose a file" + <*> areq textField textSettings Nothing + -- Add attributes like the placeholder and CSS classes. + where textSettings = FieldSettings + { fsLabel = "What's on the file?" + , fsTooltip = Nothing + , fsId = Nothing + , fsName = Nothing + , fsAttrs = + [ ("class", "form-control") + , ("placeholder", "File description") + ] + } diff --git a/src/Handler/TodoEntry.hs b/src/Handler/TodoEntry.hs new file mode 100644 index 0000000..757d024 --- /dev/null +++ b/src/Handler/TodoEntry.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +module Handler.TodoEntry where + +import Import +import Text.Read +import Database.Persist.Sql (rawExecute, fromSqlKey, toSqlKey) +-- TODO: move this back to another handler +getHomeR :: Handler Html +getHomeR = do + user <- getUserId + groups <- runDB $ do + selectList [GroupUserUser ==. user] [Asc GroupUserGroup] + mToken <- fmap reqToken getRequest + defaultLayout $ do + setTitle "Groups" + [whamlet| + Home +