blob: 8dceda5dd3e842d13254a53fc9a5b44458d24322 (
plain)
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
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Server.Frontend.Routes where
import Config (ServerConfig (..), UffdConfig (..))
import Control.Monad (forM_)
import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LB
import Data.Functor ((<&>))
import Data.Pool (Pool)
import qualified Data.Text as T
import Data.Time (UTCTime)
import Data.Time.Calendar (Day)
import Data.UUID (UUID)
import Database.Persist.Sql (SqlBackend, runSqlPool)
import qualified GTFS
import Persist (Token)
import Text.Blaze.Internal (MarkupM (Empty))
import Yesod
import Yesod.Auth
import Yesod.Auth.OAuth2.Prelude
import Yesod.Auth.Uffd (UffdUser (..), uffdClient)
import Yesod.Orphans ()
data Frontend = Frontend
{ getGtfs :: GTFS.GTFS
, getPool :: Pool SqlBackend
, getSettings :: ServerConfig
}
mkMessage "Frontend" "messages" "en"
mkYesodData "Frontend" [parseRoutes|
/ RootR GET
/auth AuthR Auth getAuth
/tickets TicketsR GET
/ticket/#UUID TicketViewR GET
/ticket/map/#UUID TicketMapViewR GET
/ticket/announce/#UUID AnnounceR POST
/ticket/del-announce/#UUID DelAnnounceR GET
/spacetime SpaceTimeDiagramR GET
/token/block/#Token TokenBlock GET
/gtfs/trips GtfsTripsViewR GET
/gtfs/trip/#GTFS.TripId GtfsTripViewR GET
/gtfs/import/#Day GtfsTicketImportR POST
/tracker OnboardTrackerR GET
|]
emptyMarkup :: MarkupM a -> Bool
emptyMarkup (Empty _) = True
emptyMarkup _ = False
instance Yesod Frontend where
authRoute _ = Just $ AuthR LoginR
isAuthorized OnboardTrackerR _ = pure Authorized
isAuthorized (AuthR _) _ = pure Authorized
isAuthorized _ _ = do
UffdConfig{..} <- getYesod <&> serverConfigLogin . getSettings
if uffdConfigEnable then maybeAuthId >>= \case
Just _ -> pure Authorized
Nothing -> pure AuthenticationRequired
else pure Authorized
defaultLayout w = do
PageContent{..} <- widgetToPageContent w
msgs <- getMessages
withUrlRenderer [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>
$if emptyMarkup pageTitle
Tracktrain
$else
#{pageTitle}
$maybe description <- pageDescription
<meta name="description" content="#{description}">
^{pageHead}
<link rel="stylesheet" href="/assets/style.css">
<meta name="viewport" content="width=device-width, initial-scale=1">
<body>
$forall (status, msg) <- msgs
<!-- <p class="message #{status}">#{msg} -->
^{pageBody}
|]
instance RenderMessage Frontend FormMessage where
renderMessage _ _ = defaultFormMessage
instance YesodPersist Frontend where
type YesodPersistBackend Frontend = SqlBackend
runDB action = do
pool <- getYesod <&> getPool
runSqlPool action pool
-- this instance is only slightly cursed (it keeps login information
-- as json in a session cookie and hopes nothing will ever go wrong)
instance YesodAuth Frontend where
type AuthId Frontend = UffdUser
authPlugins cr = case config of
UffdConfig {..} -> if uffdConfigEnable
then [ uffdClient uffdConfigUrl uffdConfigClientName uffdConfigClientSecret ]
else []
where config = serverConfigLogin (getSettings cr)
maybeAuthId = do
e <- lookupSession "json"
pure $ case e of
Nothing -> Nothing
Just extra -> A.decode (LB.fromStrict $ C8.pack $ T.unpack extra)
authenticate creds = do
forM_ (credsExtra creds) (uncurry setSession)
-- extra <- lookupSession "extra"
-- pure (Authenticated ( undefined))
e <- lookupSession "json"
case e of
Nothing -> error "no session information"
Just extra -> case A.decode (LB.fromStrict $ C8.pack $ T.unpack extra) of
Nothing -> error "malformed session information"
Just user -> pure $ Authenticated user
loginDest _ = RootR
logoutDest _ = RootR
-- hardcode redirecting to uffd directly; showing the normal login
-- screen is kinda pointless when there's only one option
loginHandler = do
redirect ("/auth/page/uffd/forward" :: Text)
onLogout = do
clearSession
|
