Merge branch 'master' into feat/exercises

2018-03-07 13:31:08 +01:00 · 2018-03-07 13:31:08 +01:00 · 4c65d379af
commit 4c65d379af
parent 27507906d1 2fb478e8ff
15 changed files with 102 additions and 156 deletions
--- a/fill-db.hs
+++ b/fill-db.hs
@ -30,7 +30,7 @@ main = db $ do
    , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06]
    , termLectureStart = fromGregorian 2017 10 16
    , termLectureEnd   = fromGregorian 2018 02 10
-    , termActive       = False
+    , termActive       = True
    }
  void . insert $ Term
    { termName     = summer2018
@ -68,4 +68,4 @@ main = db $ do
  void . insert $ DegreeCourse ifiMsc ffp
  void . insert $ Lecturer gkleen ffp
  void . insert $ Corrector gkleen ffp (ByProportion 1)
-  void . insert $ Sheet ffp "Blatt 1" NotGraded Nothing now now Nothing Nothing now now gkleen gkleen
+  void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen
--- a/package.yaml
+++ b/package.yaml
@ -91,7 +91,6 @@ library:
      - -Wall
      - -fwarn-tabs
      - -O0
-      - -ddump-splices
      cpp-options: -DDEVELOPMENT
    else:
      ghc-options:
--- a/shell.nix
+++ b/shell.nix
@ -1,4 +1,4 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc802" }:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "ghc822" }:

 let
  inherit (nixpkgs) pkgs;
@ -22,7 +22,7 @@ let
  '';

  override = oldAttrs: {
-    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql ]) ++ (with haskellPackages; [ stack yesod-bin ]);
+    nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
    shellHook = ''
      ${oldAttrs.shellHook}
      export PROMPT_INFO="${oldAttrs.name}"
@ -36,12 +36,12 @@ let
      psql -f ${postgresSchema} postgres
      printf "Postgres logfile is %s\nPostgres socket directory is %s\n" ''${pgLogFile} ''${pgSockDir}

-      env --unset=shellHook zsh
-      ret=$?
+      cleanup() {
+          pg_ctl stop -D ''${pgDir}
+          rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
+      }

-      pg_ctl stop -D ''${pgDir}
-      rm -rvf ''${pgDir} ''${pgSockDir} ''${pgLogFile}
-      exit ''${ret}
+      trap cleanup EXIT
    '';
  };

--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@ -74,7 +74,7 @@ getCourseListTermR tidini = do
 --   defaultLayout $ do
    setTitle "Semesterkurse"  
    linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
-    encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
+    encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)

 getCourseShowR :: TermId -> Text -> Handler Html
 getCourseShowR tid csh = do
@ -97,8 +97,7 @@ getCourseShowR tid csh = do
    $(widgetFile "course")
      
 registerButton :: Bool -> Form ()
-registerButton registered =
-    renderBootstrap3  bsHorizontalDefault $       
+registerButton registered = renderAForm FormStandard $       
      pure () <*  bootstrapSubmit regMsg 
  where 
    msg    = if registered then "Abmelden" else "Anmelden"
@ -267,7 +266,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
    --     courseId <- runMaybeT $ do
    --         cid <- cfCourseId template
    --         UUID.encrypt cidKey cid 
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ CourseForm
+    (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
      -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
      <$> aopt hiddenField "KursId"             (cfCourseId <$> template)
      <*> areq textField (fsb "Name")           (cfName     <$> template)
--- a/src/Handler/Home.bak
+++ b/src/Handler/Home.bak
@ -1,67 +0,0 @@
-{-# 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
--
-- 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
-    defaultLayout $ do
-        let (commentFormId, commentTextareaId, commentListId) = commentIds
-        aDomId <- newIdent
-        setTitle "Welcome To Yesod!"
-        $(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
-
-    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")
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@ -17,7 +17,6 @@ import Handler.Utils.Zip
 -- import Data.Time
 import qualified Data.Text as T
 -- import Data.Function ((&))
-import Yesod.Form.Bootstrap3
 -- 
 import Colonnade  -- hiding (fromMaybe)
 import Yesod.Colonnade
@ -54,7 +53,7 @@ makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm cid template = identForm FIDsheet $ \html -> do
    -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
    -- Erstmal nur mit ZIP arbeiten
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm
+    (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
      <$> areq textField    (fsb "Name")        (sfName <$> template)
      <*> aopt htmlField    (fsb "Hinweise für Teilnehmer")  (sfMarkingText <$> template)
      <*> sheetTypeAFormReq (fsb "Bewertung")   (sfType <$> template)
@ -129,7 +128,7 @@ getSheetList courseEnt = do
    setTitle $ toHtml $ T.append "Übungsblätter " csh
    if null sheets
      then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
-      else encodeHeadedWidgetTable tableDefault colSheets sheets
+      else encodeWidgetTable tableDefault colSheets sheets

 -- Show single sheet
 getSheetShowR :: TermId -> Text -> Text -> Handler Html
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@ -13,7 +13,7 @@ module Handler.Submission where

 import Import hiding (joinPath)

-import Yesod.Form.Bootstrap3  
+-- import Yesod.Form.Bootstrap3  

 import Handler.Utils

@ -72,10 +72,10 @@ submissionTable = do
 getSubmissionListR, postSubmissionListR :: Handler Html
 getSubmissionListR = postSubmissionListR
 postSubmissionListR = do
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
-    <$> areq checkBoxField (bfs ("Dies sind Korrekturen" :: Text)) (Just False)
-    <*> fileAFormReq (bfs ("Archiv" :: Text))
-    <*  bootstrapSubmit ("Mehrere Hochladen" :: BootstrapSubmit Text)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
+    <$> areq checkBoxField "Dies sind Korrekturen" (Just False)
+    <*> fileAFormReq "Archiv"
+    <*  submitButton

  runDB $ do
    case uploadResult of
@ -211,10 +211,10 @@ getSubmissionR = postSubmissionR
 postSubmissionR cID = do
  submissionId <- decrypt cID
  
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderBootstrap3 BootstrapBasicForm $ (,)
-    <$> areq checkBoxField (bfs ("Dies ist eine Korrektur" :: Text)) (Just False)
-    <*> fileAFormReq (bfs ("Datei" :: Text))
-    <*  bootstrapSubmit ("Upload" :: BootstrapSubmit Text)
+  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
+    <$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
+    <*> fileAFormReq "Datei"
+    <*  submitButton

  (submission, files) <- runDB $ do
    submission <- do
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@ -69,7 +69,7 @@ getTermShowR = do
            ]  
      defaultLayout $ do
        setTitle "Freigeschaltete Semester"            
-        encodeHeadedWidgetTable tableDefault colonnadeTerms termData
+        encodeWidgetTable tableDefault colonnadeTerms termData

    
 getTermEditR :: Handler Html
@ -128,7 +128,7 @@ wdgtTermForm formWidget formEnctype = do
      
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
-    (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term
+    (result, widget) <- flip (renderAForm FormStandard) html $ Term
      <$> areq termNewField (bfs ("Semester" :: Text)) (termName  <$> template)
      <*> areq dayField  (bfs ("Erster Tag" :: Text)) (termStart <$> template)
      <*> areq dayField  (bfs ("Letzer Tag" :: Text)) (termEnd   <$> template)
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -41,5 +41,5 @@ getUsersR = do
        -- ++  map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools
  defaultLayout $ do
    setTitle "Comprehensive User List"
-    let userList = encodeHeadedWidgetTable tableDefault colonnadeUsers users
+    let userList = encodeWidgetTable tableDefault colonnadeUsers users
    $(widgetFile "users")
--- a/src/Handler/Utils.hs
+++ b/src/Handler/Utils.hs
@ -11,7 +11,6 @@ import Import.NoFoundation
  
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Term as Handler.Utils
-import Handler.Utils.Bootstrap3 as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils

--- a/src/Handler/Utils/Bootstrap3.hs
+++ b/src/Handler/Utils/Bootstrap3.hs
@ -1,28 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module Handler.Utils.Bootstrap3 where
-
-import Import
-import Data.String (IsString(..))
-- import Yesod.Core
-- import qualified Data.Text as T
-- import Yesod.Form.Types
-- import Yesod.Form.Functions
-import Yesod.Form.Bootstrap3 
-
-bsSubmit :: String -> BootstrapSubmit Text
-bsSubmit msg = 
-  BootstrapSubmit (fromString msg) " btn-default btn-primary " []
-  
-bsHorizontalDefault :: BootstrapFormLayout
-bsHorizontalDefault = 
-  BootstrapHorizontalForm 
-    { bflLabelOffset = ColSm 1
-    , bflLabelSize   = ColSm 4
-    , bflInputOffset = ColSm 1
-    , bflInputSize   = ColSm 6
-    }
-  
--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -6,6 +6,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ViewPatterns #-}

 module Handler.Utils.Form where 

@ -22,6 +23,8 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3 

+import qualified Text.Blaze.Internal as Blaze (null)
+
 import Web.PathPieces (showToPathPiece, readFromPathPiece)

 ------------------------------------------------
@ -35,6 +38,18 @@ data FormIdentifier = FIDcourse | FIDsheet
 identForm :: FormIdentifier -> Form a -> Form a  
 identForm fid = identifyForm (T.pack $ show fid)

+-------------------
+-- Form Renderer --
+-------------------
+
+-- | Use this type to pass information to the form template
+data FormLayout = FormStandard
+
+renderAForm :: Monad m => FormLayout -> FormRender m a
+renderAForm formLayout aform fragment = do
+  (res, (($ []) -> views)) <- aFormToForm aform
+  let widget = $(widgetFile "form")
+  return (res, widget)

 ----------------------------
 -- Buttons (new version ) --
@ -70,6 +85,18 @@ instance Button StandardButton where
  cssClass BtnDelete = BCWarning
  cssClass BtnAbort  = BCDefault
  cssClass BtnSave   = BCPrimary
+
+data SubmitButton = BtnSubmit
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece SubmitButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button SubmitButton where
+  label BtnSubmit = "Submit"
+
+  cssClass BtnSubmit = BCPrimary
  
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)  
 -- data LinkButton = LinkButton (Route UniWorX)
@ -108,7 +135,10 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
 combinedButtonField1 :: Button a => [a] -> AForm Handler [Maybe a]
 combinedButtonField1 btns = traverse b2f btns
  where
-    b2f b = aopt (buttonField b) "n/a" Nothing 
+    b2f b = aopt (buttonField b) "" Nothing 
+
+submitButton :: AForm Handler ()
+submitButton = void $ combinedButtonField1 [BtnSubmit]

    {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
@ -200,7 +230,7 @@ defaultFormActions =  [ formBtnDelete
 postButtonForm :: Text -> Form ()
 postButtonForm lblId = identifyForm lblId buttonF
  where
-    buttonF = renderBootstrap3 BootstrapInlineForm $ pure () <* bootstrapSubmit bProps
+    buttonF = renderAForm FormStandard $ pure () <* bootstrapSubmit bProps
    bProps :: BootstrapSubmit Text
    bProps = fromString $ unpack lblId
    
--- a/src/Handler/Utils/Table.hs
+++ b/src/Handler/Utils/Table.hs
@ -36,7 +36,7 @@ pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
 -- Table Modification
 encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
 encodeHeadedWidgetTableNumbered attrs colo tdata =
-    encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
+    encodeWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
  where
    numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
    numberCol = headed "Nr" (fromString.show.fst)    
@ -86,5 +86,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
    collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs

  return ( catMaybes <$> collectResult selectionResults
-         , encodeHeadedCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
+         , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
         )
--- a/stack.yaml
+++ b/stack.yaml
@ -1,4 +1,5 @@
 flags: {}
+
 docker:
  enable: false
  image: uniworx
@ -6,35 +7,40 @@ nix:
  packages: []
  pure: false
  shell-file: ./stack.nix
+
 extra-package-dbs: []
+
 packages:
- .
- location:
-    git: https://github.com/pngwjpgh/zip-stream.git
-    commit: 9272bbed000928d500febad1cdc98d1da29d399e
-  extra-dep: true
- location:
-    git: https://github.com/mlitchard/yesod-auth-ldap.git
-    commit: 69e08ef687ab96df3352ff4267562135453c6f02
-  extra-dep: true
- location:
-    git: https://github.com/mlitchard/authenticate-ldap.git
-    commit: cc2770024766a8fa29d3086688df60aaf65fb954
-  extra-dep: true
+  - .
+  - location:
+      git: https://github.com/pngwjpgh/zip-stream.git
+      commit: 9272bbed000928d500febad1cdc98d1da29d399e
+    extra-dep: true
+  - location:
+      git: https://github.com/mlitchard/yesod-auth-ldap.git
+      commit: 69e08ef687ab96df3352ff4267562135453c6f02
+    extra-dep: true
+  - location:
+      git: https://github.com/mlitchard/authenticate-ldap.git
+      commit: cc2770024766a8fa29d3086688df60aaf65fb954
+    extra-dep: true
+  - location:
+      git: https://github.com/pngwjpgh/encoding.git
+      commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
+    extra-dep: true
+
 extra-deps:
- colonnade-1.1.1
- yesod-colonnade-1.1.0
-# - zip-stream-0.1.0.1
- conduit-resumablesink-0.2
- uuid-crypto-1.4.0.0
- filepath-crypto-0.1.0.0
- cryptoids-0.5.0.0
- cryptoids-types-0.0.0
- cryptoids-class-0.0.0
+  - colonnade-1.2.0
+  - yesod-colonnade-1.2.0

- encoding-0.8.2
- regex-compat-0.93.1
+  - conduit-resumablesink-0.2

- LDAP-0.6.11
-resolver: lts-9.3
-allow-newer: true
+  - uuid-crypto-1.4.0.0
+  - filepath-crypto-0.1.0.0
+  - cryptoids-0.5.0.0
+  - cryptoids-types-0.0.0
+  - cryptoids-class-0.0.0
+
+  - LDAP-0.6.11
+
+resolver: lts-10.5
--- a/templates/form.hamlet
+++ b/templates/form.hamlet
@ -0,0 +1,9 @@
+$newline never
+#{fragment}
+$case formLayout
+  $of FormStandard
+    $forall view <- views
+      <div :fvRequired view:.required :not $ fvRequired view:.optional :isJust $ fvErrors view:.has-error>
+        $if not (Blaze.null $ fvLabel view)
+          <label for=#{fvId view}>#{fvLabel view}
+        ^{fvInput view}