before flake update

.gitignore

@@ -33,3 +33,6 @@ result-*
 *.sqlite3-shm
 *.sqlite3-wal
 static/tmp/
+
+# ---> Editor
+tags

OwOpointTracker.cabal

@@ -38,11 +38,13 @@ library
       Foundation
       Handler.Common
       Handler.Home
+      Handler.Station
       Import
       Import.NoFoundation
       Model
       Settings
       Settings.StaticFiles
+      Json
   other-modules:
       Paths_OwOpointTracker
   hs-source-dirs:
@@ -75,6 +77,7 @@ library
     , template-haskell
     , text >=0.11 && <2.1
     , time
+    , tomland
     , unordered-containers
     , vector
     , wai

config/models.persistentmodels

@@ -1,18 +1,25 @@
 -- 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
 
-User
+Round
-    ident Text
+    stationId Text
-    password Text Maybe
+    tutorPoints Int
-    UniqueUser ident
+    erstiePoints Int
-    deriving Typeable
+    number Int
-Email
+    UniqueRoundStation number stationId
-    email Text
+
-    userId UserId Maybe
+--User
-    verkey Text Maybe
+--    ident Text
-    UniqueEmail email
+--    password Text Maybe
-Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
+--    UniqueUser ident
-    message Text
+--    deriving Typeable
-    userId UserId Maybe
+--Email
-    deriving Eq
+--    email Text
-    deriving Show
+--    userId UserId Maybe
+--    verkey Text Maybe
+--    UniqueEmail email
+--Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
+--    message Text
+--    userId UserId Maybe
+--    deriving Eq
+--    deriving Show

config/routes.yesodroutes

@@ -9,6 +9,13 @@
 
 / HomeR GET
 
+-- stationName
+/station/#Text StationR GET
+
+-- stationName/roundNumber
+/station/#Text/#Int StationRoundR GET POST
+
+
 -- /comments CommentR POST
 
 -- /profile ProfileR GET

config/settings.yml

@@ -37,4 +37,7 @@ database:
   poolsize: "_env:YESOD_SQLITE_POOLSIZE:10"
 
 copyright: Insert copyright statement here
-#analytics: UA-YOURCODE
+
+stations:
+  - station-id: "test"
+    station-name: "Test"

settings.yml

@@ -0,0 +1,43 @@
+# 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:OwOpointTracker.sqlite3"
+  poolsize: "_env:YESOD_SQLITE_POOLSIZE:10"
+
+copyright: Insert copyright statement here
+
+stations:
+  - station-id: "testi"
+    station-name: "Test"

src/Application.hs

@@ -42,6 +42,7 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
 -- Don't forget to add new modules to your cabal file!
 import Handler.Common
 import Handler.Home
+import Handler.Station
 
 -- 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

src/Foundation.hs

@@ -39,15 +39,15 @@ data App = App
     , appLogger      :: Logger
     }
 
-data MenuItem = MenuItem
+--data MenuItem = MenuItem
-    { menuItemLabel :: Text
+--    { menuItemLabel :: Text
-    , menuItemRoute :: Route App
+--    , menuItemRoute :: Route App
-    , menuItemAccessCallback :: Bool
+--    , menuItemAccessCallback :: Bool
-    }
+--    }
-
+--
-data MenuTypes
+--data MenuTypes
-    = NavbarLeft MenuItem
+--    = NavbarLeft MenuItem
-    | NavbarRight MenuItem
+--    | NavbarRight MenuItem
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:

src/Handler/Home.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
 module Handler.Home where
 
 import Import
@@ -28,13 +29,13 @@ getHomeR = do
 --    let submission = Nothing :: Maybe FileForm
 --        handlerName = "getHomeR" :: Text
 --    allComments <- runDB $ getAllComments
-
+    rou <- runDB $ selectList [] []
+    let rounds = fmap entityVal rou
     defaultLayout $ do
 --        let (commentFormId, commentTextareaId, commentListId) = commentIds
-        aDomId <- newIdent
         setTitle "OwO Geländespielpunkte"
-        let tutorPoints = 5 :: Int
+        let tutorP = sum (fmap roundTutorPoints rounds)
-        let erstiePoints = 3 :: Int
+        let erstieP = sum (fmap roundErstiePoints rounds)
         $(widgetFile "homepage")
 
 --postHomeR :: Handler Html

src/Handler/Station.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+module Handler.Station where
+
+import Import
+import Json
+import qualified Data.Map as M
+--import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
+--import Text.Julius (RawJS (..))
+
+checkStation :: Text -> Handler Text
+checkStation stationIdentifier = do
+  stationMap <- getsYesod (appStations . appSettings)
+  let stat = stationMap M.!? stationIdentifier :: Maybe Text
+  case stat of
+    Nothing -> notFound
+    Just m  -> return m
+
+repsertBy :: (MonadIO m, PersistUniqueRead backend, PersistRecordBackend record backend, AtLeastOneUniqueKey record, SafeToInsert record)  => record -> ReaderT backend m ()
+repsertBy val = do
+  valM <- getByValue val
+  case valM of
+    Nothing -> insert_ val
+    Just (Entity key _) -> replace key val
+
+getStationR :: Text -> Handler Html
+getStationR stationIdentifier = do
+  station <- checkStation stationIdentifier
+  rounds <- runDB $ do
+    rou <- selectList [RoundStationId ==. stationIdentifier] []
+    return (fmap entityVal rou :: [Round])
+  defaultLayout $ do
+    setTitle $ "OwO Station"
+    $(widgetFile "station")
+
+-- postStationR :: Text -> Handler Html
+-- postStationR stationIdentifier = do
+-- 	station <- checkStation stationIdentifier
+-- 	((result,widget),enctype) <- runFormPost (roundForm Nothing Nothing Nothing)
+-- 	case result of
+-- 		FormSuccess roundFormD -> do
+-- 		  runDB $ upsertBy (UniqueRoundStation (roundNumberForm roundFormD) stationIdentifier) ( Round (stationIdentifier)(tutorPointsForm roundFormD)(erstiePointsForm roundFormD)(roundNumberForm roundFormD))
+-- 		  redirect $ StationRoundR stationIdentifier (roundNumberForm roundFormD)
+-- 		FormFailure errors -> error "Form Failure"
+-- 		FormMissing -> error "Form Missing"
+
+
+data RoundForm = RoundForm
+  { tutorPointsForm :: Int
+  , erstiePointsForm :: Int
+  }
+  deriving Show
+
+roundForm :: Maybe Int -> Maybe Int -> Form RoundForm
+roundForm v w = renderDivs $ RoundForm
+    <$> areq intField "Tutor Points"  v
+    <*> areq intField "Erstie Points" w
+
+getStationRoundR :: Text -> Int -> Handler Html
+getStationRoundR stationIdentifier roundNumber = do
+  station <- checkStation stationIdentifier
+  mRoundEntity <- runDB $ getBy $ UniqueRoundStation roundNumber stationIdentifier
+  case mRoundEntity of
+    Nothing -> do
+      (roundFormWidget,roundFormEnctype) <- generateFormPost (roundForm Nothing Nothing)
+      defaultLayout $ do
+        setTitle $ "OwO Round"
+        $(widgetFile "round")
+    Just roundEntity -> do
+      let round = entityVal roundEntity
+      (roundFormWidget,roundFormEnctype) <- generateFormPost (roundForm (Just $ roundTutorPoints round) (Just $ roundErstiePoints round))
+      defaultLayout $ do
+        setTitle $ "OwO Round"
+        $(widgetFile "round")
+
+postStationRoundR :: Text -> Int -> Handler Html
+postStationRoundR stationIdentifier roundNumber = do
+  station <- checkStation stationIdentifier
+  ((result,widget),enctype) <- runFormPost (roundForm Nothing Nothing)
+  case result of
+    FormSuccess roundFormD -> do
+      runDB $ repsertBy $ Round (stationIdentifier)(tutorPointsForm roundFormD)(erstiePointsForm roundFormD) roundNumber
+      redirect $ StationRoundR stationIdentifier (roundNumber + 1)
+    FormFailure errors -> error "Form Failure"
+    FormMissing -> error "Form Missing"
+
+
+
+-- 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.
+--getHomeR :: Handler Html
+--getHomeR = do
+--    (formWidget, formEnctype) <- generateFormPost sampleForm
+--    let submission = Nothing :: Maybe FileForm
+--        handlerName = "getHomeR" :: Text
+--    allComments <- runDB $ getAllComments
+
+--    defaultLayout $ do
+--        let (commentFormId, commentTextareaId, commentListId) = commentIds
+--        aDomId <- newIdent
+--        setTitle "OwO Geländespielpunkte"
+--        let tutorPoints = 5 :: Int
+--        let erstiePoints = 3 :: Int
+--        $(widgetFile "homepage")
+
+--postHomeR :: Handler Html
+--postHomeR = do
+--    ((result, formWidget), formEnctype) <- runFormPost sampleForm
+--    let handlerName = "postHomeR" :: Text
+--        submission = case result of
+--            FormSuccess res -> Just res
+--            _ -> Nothing
+--    allComments <- runDB $ getAllComments
+--
+--    defaultLayout $ do
+--        let (commentFormId, commentTextareaId, commentListId) = commentIds
+--        aDomId <- newIdent
+--        setTitle "Welcome To Yesod!"
+--        $(widgetFile "homepage")
+--
+--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")
+--                ]
+--            }
+--
+--commentIds :: (Text, Text, Text)
+--commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
+--
+--getAllComments :: DB [Entity Comment]
+--getAllComments = selectList [] [Asc CommentId]

src/Json.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE TemplateHaskell   #-}
+
+module Json where
+
+import ClassyPrelude.Yesod
+import Data.Aeson.TH
+
+data ResRound = ResRound
+  { resRoundNumber :: Int
+  , resRoundErstiePoints :: Int
+  , resRoundTutorPoints :: Int
+  }
+  deriving Show
+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''ResRound)
+
+data ResStation = ResStation
+  { resStationName :: Text
+  }
+  deriving Show
+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''ResStation)
+
+data ResScore = ResScore
+  { resScoreErsties :: Int
+  , resScoreTutors :: Int
+  }
+  deriving Show
+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''ResScore)
+
+data ReqRoundPoints = ReqRoundPoints
+  { reqRoundPointsErsties :: Int
+  , reqRoundPointTutors :: Int
+  }
+  deriving Show
+$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''ReqRoundPoints)
+

src/Settings.hs

@@ -16,6 +16,7 @@ import Data.Aeson                  (Result (..), fromJSON, withObject, (.!=),
                                     (.:?))
 import Data.FileEmbed              (embedFile)
 import Data.Yaml                   (decodeEither')
+import qualified Data.Map          as M
 import Database.Persist.Sqlite     (SqliteConf)
 import Language.Haskell.TH.Syntax  (Exp, Name, Q)
 import Network.Wai.Handler.Warp    (HostPreference)
@@ -23,6 +24,18 @@ import Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import Yesod.Default.Util          (WidgetFileSettings, widgetFileNoReload,
                                     widgetFileReload)
 
+
+data Station = Station
+    { stationId :: Text
+    , stationName :: Text
+    }
+
+instance FromJSON Station where
+    parseJSON = withObject "Station" $ \o -> do
+      stationId   <- o .:  "station-id"
+      stationName <- o .:? "station-name" .!= "Station"
+      return Station {..}
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -56,11 +69,8 @@ data AppSettings = AppSettings
     -- Example app-specific configuration values.
     , appCopyright              :: Text
     -- ^ Copyright text to appear in the footer of the page
-    , appAnalytics              :: Maybe Text
-    -- ^ Google Analytics code
 
-    , appAuthDummyLogin         :: Bool
+    , appStations :: Map Text Text
-    -- ^ Indicate if auth dummy login should be enabled.
     }
 
 instance FromJSON AppSettings where
@@ -87,9 +97,7 @@ instance FromJSON AppSettings where
         appSkipCombining          <- o .:? "skip-combining"   .!= dev
 
         appCopyright              <- o .:  "copyright"
-        appAnalytics              <- o .:? "analytics"
+        appStations               <- M.fromList . map (\x -> (stationId x, stationName x)) <$> o .:  "stations"
-
-        appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= dev
 
         return AppSettings {..}
 

templates/homepage.hamlet

@@ -12,7 +12,7 @@
             <div .col-lg-12>
                 <div .page-header>
                     <h1 #Tutors>Tutors
-                        #{tutorPoints}
+                        #{tutorP}
 
     <hr>
 
@@ -23,5 +23,5 @@
             <div .col-lg-12>
                 <div .page-header>
                     <h1 #Ersties>Ersties
-                        #{erstiePoints}
+                        #{erstieP}
 

templates/round.hamlet

@@ -0,0 +1,14 @@
+<div .masthead>
+    <div .container>
+        <div .row>
+            <h1 .header>
+              OwO Geländespiel Station #{station} Round #{roundNumber}
+
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <form method=post action=@{StationRoundR stationIdentifier roundNumber} enctype=#{roundFormEnctype}>
+                        ^{roundFormWidget}
+                        <button> Submit

templates/station.hamlet

@@ -0,0 +1,15 @@
+<div .masthead>
+    <div .container>
+        <div .row>
+            <h1 .header>
+              OwO Geländespiel Station #{station}
+
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <ul>
+                        $forall round <- rounds
+                          <li>
+                            <a href=@{StationRoundR stationIdentifier (roundNumber round)}> #{roundNumber round}