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 DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- : dep warp
-- : dep servant-server
-- : dep lucid
-- : dep servant-lucid
module Omni.Jr.Web
( run,
defaultPort,
)
where
import Alpha
import qualified Lucid
import qualified Network.Wai.Handler.Warp as Warp
import qualified Omni.Task.Core as TaskCore
import Servant
import qualified Servant.HTML.Lucid as Lucid
defaultPort :: Warp.Port
defaultPort = 8080
type API =
Get '[Lucid.HTML] HomePage
:<|> "tasks" :> Get '[Lucid.HTML] TaskListPage
newtype HomePage = HomePage ()
newtype TaskListPage = TaskListPage [TaskCore.Task]
instance Lucid.ToHtml HomePage where
toHtmlRaw = Lucid.toHtml
toHtml (HomePage ()) =
Lucid.doctypehtml_ <| do
Lucid.head_ <| do
Lucid.title_ "Jr Web UI"
Lucid.meta_ [Lucid.charset_ "utf-8"]
Lucid.meta_
[ Lucid.name_ "viewport",
Lucid.content_ "width=device-width, initial-scale=1"
]
Lucid.body_ <| do
Lucid.h1_ "Jr Web UI"
Lucid.p_ <| Lucid.a_ [Lucid.href_ "/tasks"] "View Tasks"
instance Lucid.ToHtml TaskListPage where
toHtmlRaw = Lucid.toHtml
toHtml (TaskListPage tasks) =
Lucid.doctypehtml_ <| do
Lucid.head_ <| do
Lucid.title_ "Tasks - Jr Web UI"
Lucid.meta_ [Lucid.charset_ "utf-8"]
Lucid.meta_
[ Lucid.name_ "viewport",
Lucid.content_ "width=device-width, initial-scale=1"
]
Lucid.style_ styles
Lucid.body_ <| do
Lucid.h1_ "Tasks"
Lucid.div_ [Lucid.class_ "task-list"] <| do
traverse_ renderTask tasks
where
styles :: Text
styles =
"* { box-sizing: border-box; } \
\body { font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, sans-serif; \
\ margin: 0; padding: 16px; background: #f5f5f5; } \
\h1 { margin: 0 0 16px 0; } \
\.task-list { display: flex; flex-direction: column; gap: 8px; } \
\.task-card { background: white; border-radius: 8px; padding: 16px; \
\ box-shadow: 0 1px 3px rgba(0,0,0,0.1); } \
\.task-header { display: flex; flex-wrap: wrap; align-items: center; gap: 8px; margin-bottom: 8px; } \
\.task-id { font-family: monospace; color: #0066cc; text-decoration: none; \
\ font-size: 14px; padding: 4px 0; } \
\.task-id:hover { text-decoration: underline; } \
\.badge { display: inline-block; padding: 4px 8px; border-radius: 4px; \
\ font-size: 12px; font-weight: 500; } \
\.badge-open { background: #fef3c7; color: #92400e; } \
\.badge-inprogress { background: #dbeafe; color: #1e40af; } \
\.badge-review { background: #ede9fe; color: #6b21a8; } \
\.badge-approved { background: #d1fae5; color: #065f46; } \
\.badge-done { background: #d1fae5; color: #065f46; } \
\.priority { font-size: 12px; color: #6b7280; } \
\.task-title { font-size: 16px; margin: 0; }"
renderTask :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
renderTask t =
Lucid.div_ [Lucid.class_ "task-card"] <| do
Lucid.div_ [Lucid.class_ "task-header"] <| do
Lucid.a_
[ Lucid.class_ "task-id",
Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
]
(Lucid.toHtml (TaskCore.taskId t))
statusBadge (TaskCore.taskStatus t)
Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
statusBadge status =
let (cls, label) = case status of
TaskCore.Open -> ("badge badge-open", "Open")
TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
TaskCore.Review -> ("badge badge-review", "Review")
TaskCore.Approved -> ("badge badge-approved", "Approved")
TaskCore.Done -> ("badge badge-done", "Done")
in Lucid.span_ [Lucid.class_ cls] label
api :: Proxy API
api = Proxy
server :: Server API
server = homeHandler :<|> taskListHandler
where
homeHandler :: Servant.Handler HomePage
homeHandler = pure (HomePage ())
taskListHandler :: Servant.Handler TaskListPage
taskListHandler = do
tasks <- liftIO TaskCore.loadTasks
pure (TaskListPage tasks)
app :: Application
app = serve api server
run :: Warp.Port -> IO ()
run port = do
putText <| "Starting Jr web server on port " <> tshow port
Warp.run port app
|
