1 files changed, 145 insertions, 0 deletions
diff --git a/lib/Server/Frontend/Routes.hs b/lib/Server/Frontend/Routes.hs
new file mode 100644
index 0000000..2d74338
--- /dev/null
+++ b/lib/Server/Frontend/Routes.hs
@@ -0,0 +1,145 @@
+{-# 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
+
+/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