Home.hs 4.42 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses #-}
2
3
4
5
6
7
8
{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}

9
10
module Handler.Home where

11
12
13
import           Control.Lens                ((^.))
import           Data.Time.Clock             (addUTCTime)
import           Data.Time.Zones             (utcToLocalTimeTZ)
14
import           Data.Time.Zones.All         (tzByLabel, toTZName)
15
16
17
18
19
20
21
import           Import
import qualified Network.Google              as Google
import           Network.Google.AppsCalendar (calendarListList, clItems,
                                              cleSummary)
import           Text.Julius                 (RawJS (..))
import           Yesod.Form.Bootstrap3       (BootstrapFormLayout (..),
                                              renderBootstrap3)
22

23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
data QueryForm = QueryForm
  { queryLocation :: Location
--  , queryTimeZone :: TZLabel
  }

locationOptions :: Handler (OptionList Location)
locationOptions = do
  locs <- appLocations . appSettings <$> getYesod
  let
    mkOpt loc@Location{..} = Option locDescr loc (tshow locId)
    readOpt i = find ((== i) . locId) locs
  return $ OptionList (map mkOpt locs) (readMay >=> readOpt)

queryForm :: Maybe QueryForm -> Form QueryForm
queryForm defaultQ =
  renderBootstrap3 BootstrapBasicForm $
  QueryForm <$> areq (radioField locationOptions) "Location" (queryLocation <$> defaultQ)
--  <*> areq (selectField _) "

getHomeR :: Handler Html
getHomeR = do
  AppSettings{..} <- appSettings <$> getYesod
  let appLengths = [15, 20, 25] :: [Int]
      defaultLength = 20
      lengthRadios = zip appLengths (map (== defaultLength) appLengths)
  let currentTz = decodeUtf8 (toTZName appDefaultTimeZone)
      defaultQ = QueryForm <$> headMay appLocations
      tzs = map (decodeUtf8 . toTZName) [minBound..maxBound]
  (formWidget, formEnctype) <- generateFormPost $ queryForm defaultQ
  defaultLayout
    $(widgetFile "step1")

55
56
-- Define our data that will be used for creating the form.
data FileForm = FileForm
57
58
59
  { fileInfo        :: FileInfo
  , fileDescription :: Text
  }
60
61
62
63
64
65
66
67

-- 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.
68
69
oldgetHomeR :: Handler Html
oldgetHomeR = do
70
71
72
73
74
75
76
77
  (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")
78
79
80

postHomeR :: Handler Html
postHomeR = do
81
82
83
84
85
86
87
88
89
90
91
  ((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")
92
93

sampleForm :: Form FileForm
94
95
96
97
sampleForm =
  renderBootstrap3 BootstrapBasicForm $
  FileForm <$> fileAFormReq "Choose a file" <*>
  areq textField textSettings Nothing
98
    -- Add attributes like the placeholder and CSS classes.
99
100
101
102
103
104
105
106
107
108
  where
    textSettings =
      FieldSettings
        { fsLabel = "What's on the file?"
        , fsTooltip = Nothing
        , fsId = Nothing
        , fsName = Nothing
        , fsAttrs =
            [("class", "form-control"), ("placeholder", "File description")]
        }
109
110
111

commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
112
113
114

getCalListR :: Handler Html
getCalListR = do
115
116
117
118
  AppSettings {..} <- appSettings <$> getYesod
  endUTC <- liftIO $ addUTCTime appLookahead <$> getCurrentTime
  let endLocal = utcToLocalTimeTZ (tzByLabel appDefaultTimeZone) endUTC
  xs <- runGoogle $ Google.send calendarListList
119
120
121
  defaultLayout
    [whamlet|
            <h2>Hello calendar
122
            <pre>#{show endLocal}
123
124
125
126
127
            <ol>
              $forall itemOpt <- xs ^. clItems
                $maybe item <- itemOpt ^. cleSummary
                  <li>#{item}
            |]