commit 59e14ce390856825b859413ed91e82b5a952bdc8 Author: Stuce Date: Sat Jun 7 16:04:51 2025 +0100 version 1 done 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 0000000..9dd5f35 Binary files /dev/null and b/config/favicon.ico differ diff --git a/config/keter.yml b/config/keter.yml new file mode 100644 index 0000000..c6cbf9d --- /dev/null +++ b/config/keter.yml @@ -0,0 +1,73 @@ +# After you've edited this file, remove the following line to allow +# `yesod keter` to build your bundle. +# +# Also, please make sure that `port` value on `config/settings.yaml` is set to +# use `PORT` env variable. +user-edited: false + +# A Keter app is composed of 1 or more stanzas. The main stanza will define our +# web application. See the Keter documentation for more information on +# available stanzas. +stanzas: + + # Your Yesod application. + - type: webapp + + # Name of your executable. You are unlikely to need to change this. + # Note that all file paths are relative to the keter.yml file. + # + # The path given is for Stack projects. If you're still using cabal, change + # to + # exec: ../dist/build/sTodo/sTodo + exec: ../dist/bin/sTodo + + # Command line options passed to your application. + args: [] + + hosts: + # You can specify one or more hostnames for your application to respond + # to. The primary hostname will be used for generating your application + # root. + - www.sTodo.com + + # Enable to force Keter to redirect to https + # Can be added to any stanza + requires-secure: false + + # Static files. + - type: static-files + hosts: + - static.sTodo.com + root: ../static + + # Uncomment to turn on directory listings. + # directory-listing: true + + # Redirect plain domain name to www. + - type: redirect + + hosts: + - sTodo.com + actions: + - host: www.sTodo.com + # secure: false + # port: 80 + + # Uncomment to switch to a non-permanent redirect. + # status: 303 + +# Use the following to automatically copy your bundle upon creation via `yesod +# keter`. Uses `scp` internally, so you can set it to a remote destination +# copy-to: user@host:/opt/keter/incoming/ + +# You can pass arguments to `scp` used above. This example limits bandwidth to +# 1024 Kbit/s and uses port 2222 instead of the default 22 +# copy-to-args: +# - "-l 1024" +# - "-P 2222" + +# If you would like to have Keter automatically create a PostgreSQL database +# and set appropriate environment variables for it to be discovered, uncomment +# the following line. +# plugins: +# postgres: true diff --git a/config/models.persistentmodels b/config/models.persistentmodels new file mode 100644 index 0000000..b2a31b7 --- /dev/null +++ b/config/models.persistentmodels @@ -0,0 +1,20 @@ +-- By default this file is used by `persistFileWith` in Model.hs (which is imported by Foundation.hs) +-- Syntax for this file here: https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md + +TodolistItem + todolistId TodolistId OnDeleteCascade + value Bool + name Text +Todolist + groupId GroupId OnDeleteCascade + title Text + UniqueListPair groupId title +User + name Text + UniqueName name +Group + group Text +GroupUser + user UserId + group Text + groupId GroupId OnDeleteCascade \ No newline at end of file diff --git a/config/robots.txt b/config/robots.txt new file mode 100644 index 0000000..7d329b1 --- /dev/null +++ b/config/robots.txt @@ -0,0 +1 @@ +User-agent: * diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes new file mode 100644 index 0000000..9413671 --- /dev/null +++ b/config/routes.yesodroutes @@ -0,0 +1,25 @@ +-- By default this file is used by `parseRoutesFile` in Foundation.hs +-- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers + +/static StaticR Static appStatic + +/favicon.ico FaviconR GET +/robots.txt RobotsR GET + +/ HomeR GET +/group/#GroupId TodolistR GET + +/add AddGroupR POST +/add/group/#GroupId AddTodolistR POST +/group/#GroupId/todolist/#TodolistId TodolistItemsR GET +/add/group/#GroupId/todolist/#TodolistId AddTodolistItemR POST + +/check/group/#GroupId/todolist/#TodolistId/#TodolistItemId CheckTodolistItemR POST +/edit/group/#GroupId/todolist/#TodolistId EditTodolistItemsR GET POST + +/edit/group/#GroupId EditTodolistR GET POST +/edit EditGroupR GET POST + +/delete DeleteGroupR POST +/delete/group/#GroupId DeleteTodolistR POST + diff --git a/config/settings.yml b/config/settings.yml new file mode 100644 index 0000000..dce5c99 --- /dev/null +++ b/config/settings.yml @@ -0,0 +1,40 @@ +# Values formatted like "_env:YESOD_ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. +# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables + +static-dir: "_env:YESOD_STATIC_DIR:static" +host: "_env:YESOD_HOST:*4" # any IPv4 host +port: "_env:YESOD_PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line. +# For `keter` user, enable the follwing line, and comment out previous one. +#port: "_env:PORT:3000" # `keter` uses `PORT` env var name + +ip-from-header: "_env:YESOD_IP_FROM_HEADER:false" + +# Default behavior: determine the application root from the request headers. +# Uncomment to set an explicit approot +#approot: "_env:YESOD_APPROOT:http://localhost:3000" + +# By default, `yesod devel` runs in development, and built executables use +# production settings (see below). To override this, use the following: +# +# development: false + +# Optional values with the following production defaults. +# In development, they default to the inverse. +# +# detailed-logging: false +# should-log-all: false +# reload-templates: false +# mutable-static: false +# skip-combining: false +# auth-dummy-login : false + +# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'") +# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings + +database: + # See config/test-settings.yml for an override during tests + database: "_env:YESOD_SQLITE_DATABASE:sTodo.sqlite3" + poolsize: "_env:YESOD_SQLITE_POOLSIZE:10" + +copyright: Insert copyright statement here +#analytics: UA-YOURCODE diff --git a/config/test-settings.yml b/config/test-settings.yml new file mode 100644 index 0000000..2185541 --- /dev/null +++ b/config/test-settings.yml @@ -0,0 +1,11 @@ +database: + # NOTE: By design, this setting prevents the SQLITE_DATABASE environment variable + # from affecting test runs, so that we don't accidentally affect the + # production database during testing. If you're not concerned about that and + # would like to have environment variable overrides, you could instead use + # something like: + # + # database: "_env:SQLITE_DATABASE:sTodo_test.sqlite3" + database: sTodo_test.sqlite3 + +auth-dummy-login: true diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..f6da486 --- /dev/null +++ b/package.yaml @@ -0,0 +1,100 @@ +name: sTodo +version: "0.0.0" + +dependencies: + +- base >=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 +