From 50abccd8a4243c561cc39c54f84ddfaae8c73120 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Tue, 18 Aug 2020 14:40:10 +0200 Subject: Refactor: remove BaseUrl --- server/lib/Uplcg/BaseUrl.hs | 17 ------------- server/lib/Uplcg/Config.hs | 21 ---------------- server/lib/Uplcg/Main/Server.hs | 56 +++++++++++++---------------------------- server/lib/Uplcg/Views.hs | 29 ++++++++------------- 4 files changed, 28 insertions(+), 95 deletions(-) delete mode 100644 server/lib/Uplcg/BaseUrl.hs delete mode 100644 server/lib/Uplcg/Config.hs (limited to 'server/lib/Uplcg') 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 -- cgit v1.2.3