-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathMatchEntry.hs
132 lines (121 loc) · 4.22 KB
/
MatchEntry.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
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
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
#ifndef MIN_VERSION_time
#define MIN_VERSION_time(x,y,z) 1
#endif
module MatchEntry (matchEntryPage) where
import Control.Monad.IO.Class
import Data.Text (Text)
import Data.List (sort, sortBy)
import Data.Ord (comparing)
import Control.Lens.Combinators
import Data.Time
import Text.Hamlet (shamlet, Html)
import qualified Data.Map as Map
import Data.Map (Map)
import NewTTRS.Match (Match, matchTime, matchWinner, matchLoser)
import Snap.Snaplet.SqliteSimple
import DataStore
import Player (Player, playerName)
import Output.Common (metaTags, navigationLinks)
import Output.Formatting (formatLongDay)
#if !(MIN_VERSION_time(1,5,0))
import System.Locale (defaultTimeLocale)
#endif
matchEntryPage ::
(HasSqlite m, MonadIO m) =>
Maybe Text {- ^ error message -} ->
Text {- ^ initial winner text -} ->
Text {- ^ initial wins -} ->
Text {- ^ initial loser text -} ->
Text {- ^ initial losses text -} ->
Bool {- ^ offer to create -} ->
m Html
matchEntryPage err w wins l losses offerCreate =
do now <- liftIO getZonedTime
let today = localDay (zonedTimeToLocalTime now)
tz = zonedTimeZone now
mb <- getEventIdByDay today
ps <- getPlayers
ms <- case mb of
Nothing -> return Map.empty
Just eventId -> getMatchesByEventId eventId
namedMatches <- maybe (error "unknown player id") return
$ (traverse . traverse) (flip Map.lookup ps) ms
return $ thePage err w wins l losses (sort (Map.elems ps)) offerCreate
$ formatMatches tz today namedMatches
thePage :: Maybe Text -> Text -> Text -> Text -> Text -> [Player] -> Bool -> Html -> Html
thePage err w wins l losses ps offerCreate table = [shamlet|
<html lang=en>
<head>
^{metaTags}
<title>Ping Pong Results
<link rel=stylesheet type=text/css href=/static/common.css>
<link rel=stylesheet type=text/css href=/static/style.css>
<script type=text/javascript src=/static/entry.js>
<body>
^{navigationLinks}
<div .entry>
<form action="/match" method=POST>
<input autocomplete=off list=players name=winner #winner value=#{w}>
won
<input type=text .outcomeNumber autocomplete=off name=wins maxlength=1 value=#{wins} onkeyup="numberchange(this.value, 'winsPlural');">
game#
<span #winsPlural>s
<br>
<input autocomplete=off list=players name=loser #loser value=#{l}>
won
<input type=text .outcomeNumber autocomplete=off name=losses maxlength=1 value=#{losses} onkeyup="numberchange(this.value, 'lossesPlural');">
game#
<span #lossesPlural>s
<br>
<input type=hidden name=create value=#{offerCreate}>
<input type=submit #submit value=#{submitText}>
<datalist #players>
$forall p <- ps
<option value=#{view playerName p}>
$maybe errMsg <- err
<div #errorMessage>#{errMsg}
^{table}
|]
where
submitText = if offerCreate then "Confirm New Players" else "Save Match"
formatMatch :: TimeZone -> Int -> MatchId -> Match Player -> Html
formatMatch tz i (MatchId mid) match = [shamlet|
<tr :odd i:.alt>
<td>#{t}
<td>#{w}
<td>#{l}
<td>
<form .deleteform action="/matchop" method=post>
<input type=hidden name=matchId value=#{show mid}>
<input .deletebutton type=submit name=action value="delete">
^{extraActions}
|]
where
t = view (matchTime . to (formatTime defaultTimeLocale "%X" . utcToLocalTime tz)) match
w = view (matchWinner . playerName) match
l = view (matchLoser . playerName) match
extraActions
| i == 0 =
[shamlet|
<input .deletebutton type=submit name=action value="copy">
<input .deletebutton type=submit name=action value="swapped">
|]
| otherwise = [shamlet| |]
formatMatches :: TimeZone -> Day -> Map MatchId (Match Player) -> Html
formatMatches tz d xs
| Map.null xs = return ()
| otherwise = [shamlet|
<h2>Matches for #{formatLongDay d}
<table>
<tr>
<th>Time
<th>Winner
<th>Loser
<th>Actions
$forall (i,(fn,m)) <- itoList $ sortBy (flip byTime) $ Map.toList xs
^{formatMatch tz i fn m}
|]
where
byTime = comparing (view matchTime . snd)