Refactor: remove BaseUrl

5 files changed, 28 insertions, 97 deletions

diff --git a/server/lib/Uplcg/BaseUrl.hs b/server/lib/Uplcg/BaseUrl.hs
deleted file mode 100644
index f49d0d0..0000000
--- a/server/lib/Uplcg/BaseUrl.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Uplcg.BaseUrl
-    ( BaseUrl (..)
-    , parse
-    , render
-    ) where
-
-import qualified Data.Text as T
-
-newtype BaseUrl = BaseUrl [T.Text] deriving (Show)
-
-render :: BaseUrl -> T.Text
-render (BaseUrl []) = ""
-render (BaseUrl xs) = "/" <> T.intercalate "/" xs
-
-parse :: T.Text -> BaseUrl
-parse = BaseUrl . filter (not . T.null) . T.split (== '/')
diff --git a/server/lib/Uplcg/Config.hs b/server/lib/Uplcg/Config.hs
deleted file mode 100644
index 9197d97..0000000
--- a/server/lib/Uplcg/Config.hs
+++ /dev/null
@@ -1,21 +0,0 @@
-module Uplcg.Config
-    ( Config (..)
-    , fromEnv
-    ) where
-
-import qualified Data.Text          as T
-import           System.Environment (getEnv)
-import           Uplcg.BaseUrl      (BaseUrl)
-import qualified Uplcg.BaseUrl      as BaseUrl
-
-data Config = Config
-    { cHostname :: String
-    , cPort     :: Int
-    , cBaseUrl  :: BaseUrl
-    } deriving (Show)
-
-fromEnv :: IO Config
-fromEnv = Config
-    <$> getEnv "UPLCG_HOSTNAME"
-    <*> (read <$> getEnv "UPLCG_PORT")
-    <*> (BaseUrl.parse . T.pack <$> getEnv "UPLCG_BASE")
diff --git a/server/lib/Uplcg/Main/Server.hs b/server/lib/Uplcg/Main/Server.hs
index 2f9a70f..1672d84 100644
--- a/server/lib/Uplcg/Main/Server.hs
+++ b/server/lib/Uplcg/Main/Server.hs
@@ -21,14 +21,12 @@ import           Data.Char                       (isAlphaNum)
 import           Data.Foldable                   (for_)
 import           Data.Hashable                   (Hashable)
 import qualified Data.HashMap.Strict             as HMS
-import qualified Data.List                       as L
-import           Data.Maybe                      (fromMaybe, isNothing)
+import           Data.Maybe                      (isNothing)
 import           Data.String                     (fromString)
 import qualified Data.Text                       as T
 import qualified Data.Text.Encoding              as T
 import qualified Data.Text.IO                    as T
 import qualified Data.Text.Lazy                  as TL
-import qualified Data.Text.Lazy.Encoding         as TL
 import           Data.Traversable                (for)
 import qualified Data.Vector                     as V
 import qualified Network.HTTP.Types.Status       as HttpStatus
@@ -38,13 +36,10 @@ import qualified Network.Wai.Handler.Warp        as Warp
 import qualified Network.Wai.Handler.WebSockets  as WaiWs
 import qualified Network.Wai.Middleware.HttpAuth as HttpAuth
 import qualified Network.WebSockets              as WS
+import           System.Environment              (getEnv)
 import qualified System.Log.FastLogger           as FL
 import           System.Random                   (StdGen, newStdGen)
 import           Text.Blaze.Html.Renderer.Text   (renderHtml)
-import           Uplcg.BaseUrl                   (BaseUrl)
-import qualified Uplcg.BaseUrl                   as BaseUrl
-import           Uplcg.Config                    (Config)
-import qualified Uplcg.Config                    as Config
 import qualified Uplcg.CookieSocket              as CookieSocket
 import           Uplcg.Game
 import           Uplcg.Messages
@@ -66,8 +61,7 @@ data Room = Room
     }
 
 data Server = Server
-    { serverConfig       :: Config
-    , serverLogger       :: FL.FastLogger
+    { serverLogger       :: FL.FastLogger
     , serverCookieSocket :: CookieSocket.Handle Player
     , serverCards        :: Cards
     , serverRooms        :: MVar (HMS.HashMap RoomId Room)
@@ -81,9 +75,9 @@ readCards = Cards
     parseCards  = V.fromList . filter (not . T.null) . map dropComment . T.lines
     dropComment = T.strip . fst . T.break (== '#')
 
-withServer :: Config -> FL.FastLogger -> (Server -> IO a) -> IO a
-withServer conf fl f = CookieSocket.withHandle 5 $ \cs -> do
-    f =<< Server conf fl cs <$> readCards <*> MVar.newMVar HMS.empty
+withServer :: FL.FastLogger -> (Server -> IO a) -> IO a
+withServer fl f = CookieSocket.withHandle 5 $ \cs -> do
+    f =<< Server fl cs <$> readCards <*> MVar.newMVar HMS.empty
 
 newRoom :: RoomId -> RoomPassword -> Cards -> StdGen -> STM Room
 newRoom rid rpw cards gen = Room rid rpw
@@ -150,20 +144,17 @@ getPassword = do
 
 scottyApp :: Server -> IO Wai.Application
 scottyApp server = Scotty.scottyApp $ do
-    Scotty.get "/" $
-        Scotty.redirect $ TL.fromStrict $
-            BaseUrl.render (Config.cBaseUrl $ serverConfig server) <> "/rooms"
+    Scotty.get "/" $ Scotty.redirect $ "/rooms"
 
     Scotty.get "/rooms" $ do
         views <- liftIO $ roomViews server
-        Scotty.html . renderHtml $ Views.rooms (serverConfig server) views
+        Scotty.html . renderHtml $ Views.rooms views
 
     Scotty.post "/rooms" $ do
         rid <- getParam "id"
         rpw <- getParam "password"
         _   <- liftIO $ createRoom server rid rpw
         Scotty.redirect $ TL.fromStrict $
-            BaseUrl.render (Config.cBaseUrl $ serverConfig server) <>
             "/rooms/" <> unRoomId rid <>
             case rpw of
                 NoRoomPassword -> ""
@@ -179,12 +170,12 @@ scottyApp server = Scotty.scottyApp $ do
                 liftIO $ print mbGiven
                 case mbGiven of
                     Just given | given == actual ->
-                        Scotty.html . renderHtml $ Views.client (serverConfig server) ridt $ Just actual
+                        Scotty.html . renderHtml $ Views.client ridt $ Just actual
                     _ -> do
                         Scotty.status HttpStatus.unauthorized401
                         Scotty.setHeader "WWW-Authenticate" "Basic realm=\"Provide password, user is ignored\", charset=\"UTF-8\""
             NoRoomPassword ->
-                Scotty.html . renderHtml $ Views.client (serverConfig server) ridt Nothing
+                Scotty.html . renderHtml $ Views.client ridt Nothing
 
     Scotty.get "/assets/client.js" $ do
         Scotty.setHeader "Content-Type" "application/JavaScript"
@@ -200,8 +191,8 @@ parsePendingConnection pending =
         (pathPart, queryPart) = second (B.drop 1) $ BC.break (== '?') path
         pwd = fmap T.decodeUtf8 .
             lookup "password" $ HttpUri.parseSimpleQuery queryPart in
-    case BaseUrl.parse (T.decodeUtf8 pathPart) of
-        BaseUrl.BaseUrl ["rooms", txt, "events"] | Right r <- parseRoomId txt ->
+    case filter (not . T.null) . T.split (== '/') $ T.decodeUtf8 pathPart of
+        ["rooms", txt, "events"] | Right r <- parseRoomId txt ->
             Just (r, maybe NoRoomPassword RoomPassword pwd)
         _ -> Nothing
 
@@ -303,29 +294,16 @@ wsApp server pc = case parsePendingConnection pc of
                 serverLogger server $ "Could not decode client message: " <>
                     FL.toLogStr (show msg)
 
-baseUrl :: BaseUrl -> Wai.Middleware
-baseUrl base@(BaseUrl.BaseUrl prefix) application = \req ->
-    case L.stripPrefix prefix (Wai.pathInfo req) of
-        Nothing   -> application req
-        Just path -> application req
-            { Wai.pathInfo = path
-            , Wai.rawPathInfo = fromMaybe (Wai.rawPathInfo req) .
-                B.stripPrefix bs $ Wai.rawPathInfo req
-            }
-  where
-    bs = T.encodeUtf8 $ BaseUrl.render base
-
 main :: IO ()
 main = do
-    config <- Config.fromEnv
-    let settings = Warp.setPort (Config.cPort config) .
-            Warp.setHost (fromString $ Config.cHostname config) $
-            Warp.defaultSettings
+    host <- fromString <$> getEnv "UPLCG_HOSTNAME"
+    port <- read <$> getEnv "UPLCG_PORT"
+    let settings = Warp.setPort port $ Warp.setHost host Warp.defaultSettings
     timeCache <- FL.newTimeCache FL.simpleTimeFormat
     FL.withTimedFastLogger timeCache
             (FL.LogStderr FL.defaultBufSize) $ \tfl ->
         let fl s = tfl (\time -> FL.toLogStr time <> " " <> s <> "\n") in
-        withServer config fl $ \server -> do
+        withServer fl $ \server -> do
         sapp <- scottyApp server
-        Warp.runSettings settings $ baseUrl (Config.cBaseUrl config) $
+        Warp.runSettings settings $
             WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
diff --git a/server/lib/Uplcg/Views.hs b/server/lib/Uplcg/Views.hs
index fc7042b..d25a9ce 100644
--- a/server/lib/Uplcg/Views.hs
+++ b/server/lib/Uplcg/Views.hs
@@ -13,34 +13,30 @@ import qualified Data.Text.Encoding           as T
 import qualified Network.HTTP.Types.URI       as HttpUri
 import qualified Text.Blaze.Html5             as H
 import qualified Text.Blaze.Html5.Attributes  as A
-import qualified Uplcg.BaseUrl                as BaseUrl
-import           Uplcg.Config
 import           Uplcg.Version                (version)
 
 data RoomView = RoomView Text Bool Int
 
-template :: Config -> Text -> H.Html -> H.Html
-template conf title body = H.docTypeHtml $ do
+template :: Text -> H.Html -> H.Html
+template title body = H.docTypeHtml $ do
     H.head $ do
         H.meta H.! A.charset "UTF-8"
         H.link H.! A.rel "stylesheet" H.! A.type_ "text/css"
-            H.! A.href (H.toValue $
-                BaseUrl.render (cBaseUrl conf) <> "/assets/style.css")
+            H.! A.href "/assets/style.css"
         H.title $ H.toHtml title
         H.meta H.! A.name "viewport" H.! A.content "width=device-width"
     H.body $ do
         body
         H.footer $ "Untitled PL Card Game version " <> H.toHtml version
 
-rooms :: Config -> [RoomView] -> H.Html
-rooms conf rids = template conf "Untitled PL Card Game" $
+rooms :: [RoomView] -> H.Html
+rooms rids = template "Untitled PL Card Game" $
     H.div H.! A.class_ "rooms" $ do
         H.h1 "Rooms"
         if null rids
             then H.p "No rooms online."
             else H.ul $ for_ rids $ \(RoomView rid lock num) -> H.li $ do
-                H.a H.! A.href (H.toValue $
-                        BaseUrl.render (cBaseUrl conf) <> "/rooms/" <> rid) $
+                H.a H.! A.href (H.toValue $ "/rooms/" <> rid) $
                     H.toHtml rid
                 when lock  " 🔒"
                 " ("
@@ -49,8 +45,7 @@ rooms conf rids = template conf "Untitled PL Card Game" $
 
         H.br
         H.h1 "Create Room"
-        H.form H.! A.method "POST" H.! A.action (H.toValue $
-                BaseUrl.render (cBaseUrl conf) <> "/rooms") $ do
+        H.form H.! A.method "POST" H.! A.action "/rooms" $ do
             H.label H.! A.for "name" $ "Room name: "
             H.input H.! A.type_ "text" H.! A.name "id"
             H.br
@@ -59,12 +54,11 @@ rooms conf rids = template conf "Untitled PL Card Game" $
             H.br
             H.input H.! A.type_ "submit" H.! A.value "Create room"
 
-client :: Config -> Text -> Maybe Text -> H.Html
-client conf roomId mbPassword = template conf "Untitled PL Card Game" $ do
+client :: Text -> Maybe Text -> H.Html
+client roomId mbPassword = template "Untitled PL Card Game" $ do
     H.div H.! A.id "main" $ ""
     H.script H.! A.type_ "text/JavaScript"
-        H.! A.src (H.toValue $
-            BaseUrl.render (cBaseUrl conf) <> "/assets/client.js") $ ""
+        H.! A.src "/assets/client.js" $ ""
     H.script H.! A.type_ "text/JavaScript" $ H.unsafeLazyByteString entryPoint
   where
     t2b = BLB.byteString . T.encodeUtf8
@@ -77,8 +71,7 @@ client conf roomId mbPassword = template conf "Untitled PL Card Game" $ do
       "    protocol = 'wss:'" <>
       "  }" <>
       "  var url = protocol + '//' + document.location.host +" <>
-      "    '" <> t2b (BaseUrl.render $ cBaseUrl conf) <> "/rooms/" <>
-          t2b roomId <> "/events" <>
+      "    '/rooms/" <> t2b roomId <> "/events" <>
           (case mbPassword of
               Nothing -> ""
               Just pwd -> BLB.byteString $ HttpUri.renderSimpleQuery True
diff --git a/server/uplcg.cabal b/server/uplcg.cabal
index d8d375d..5ed6d2f 100644
--- a/server/uplcg.cabal
+++ b/server/uplcg.cabal
@@ -17,9 +17,7 @@ Library
   Other-modules:    Paths_uplcg
 
   Exposed-modules:
-    Uplcg.BaseUrl
     Uplcg.CookieSocket
-    Uplcg.Config
     Uplcg.Game
     Uplcg.Main.GenerateElmTypes
     Uplcg.Main.Server