before flake update

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
-    { menuItemLabel :: Text
-    , menuItemRoute :: Route App
-    , menuItemAccessCallback :: Bool
-    }
-
-data MenuTypes
-    = NavbarLeft MenuItem
-    | NavbarRight MenuItem
+--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:

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 erstiePoints = 3 :: Int
+        let tutorP = sum (fmap roundTutorPoints rounds)
+        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
-    -- ^ Indicate if auth dummy login should be enabled.
+    , appStations :: Map Text Text
     }
 
 instance FromJSON AppSettings where
@@ -87,9 +97,7 @@ instance FromJSON AppSettings where
         appSkipCombining          <- o .:? "skip-combining"   .!= dev
 
         appCopyright              <- o .:  "copyright"
-        appAnalytics              <- o .:? "analytics"
-
-        appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= dev
+        appStations               <- M.fromList . map (\x -> (stationId x, stationName x)) <$> o .:  "stations"
 
         return AppSettings {..}