diff --git a/.gitignore b/.gitignore index 9daf56b..292729b 100644 --- a/.gitignore +++ b/.gitignore @@ -33,3 +33,6 @@ result-* *.sqlite3-shm *.sqlite3-wal static/tmp/ + +# ---> Editor +tags diff --git a/OwOpointTracker.cabal b/OwOpointTracker.cabal index 0ba5298..e854b55 100644 --- a/OwOpointTracker.cabal +++ b/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 diff --git a/config/models.persistentmodels b/config/models.persistentmodels index 65a0be3..1552258 100644 --- a/config/models.persistentmodels +++ b/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 - ident Text - password Text Maybe - UniqueUser ident - deriving Typeable -Email - email Text - 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 +Round + stationId Text + tutorPoints Int + erstiePoints Int + number Int + UniqueRoundStation number stationId + +--User +-- ident Text +-- password Text Maybe +-- UniqueUser ident +-- deriving Typeable +--Email +-- email Text +-- 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 diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index 342837b..b069d4f 100644 --- a/config/routes.yesodroutes +++ b/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 diff --git a/config/settings.yml b/config/settings.yml index 216c9d5..6d5445c 100644 --- a/config/settings.yml +++ b/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" diff --git a/settings.yml b/settings.yml new file mode 100644 index 0000000..e42aafd --- /dev/null +++ b/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" diff --git a/src/Application.hs b/src/Application.hs index e05dd18..1d42428 100644 --- a/src/Application.hs +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 8a58789..2e0ba24 100644 --- a/src/Foundation.hs +++ b/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: diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 4af4112..b14fdb2 100644 --- a/src/Handler/Home.hs +++ b/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 diff --git a/src/Handler/Station.hs b/src/Handler/Station.hs new file mode 100644 index 0000000..fccd8bd --- /dev/null +++ b/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] diff --git a/src/Json.hs b/src/Json.hs new file mode 100644 index 0000000..e9f0b19 --- /dev/null +++ b/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) + diff --git a/src/Settings.hs b/src/Settings.hs index 5da2963..8c347c4 100644 --- a/src/Settings.hs +++ b/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 {..} diff --git a/templates/homepage.hamlet b/templates/homepage.hamlet index c5dd632..caa3a3c 100644 --- a/templates/homepage.hamlet +++ b/templates/homepage.hamlet @@ -12,7 +12,7 @@

Tutors - #{tutorPoints} + #{tutorP}
@@ -23,5 +23,5 @@

Ersties - #{erstiePoints} + #{erstieP} diff --git a/templates/round.hamlet b/templates/round.hamlet new file mode 100644 index 0000000..f3ca52e --- /dev/null +++ b/templates/round.hamlet @@ -0,0 +1,14 @@ +
+
+
+

+ OwO Geländespiel Station #{station} Round #{roundNumber} + +
+
+
+
+
+
+ ^{roundFormWidget} +