de8f6fc · obelisk · git.iko.soy

git.iko.soy/obelisk

Move ensureSecure from obelisk-snap to obelisk-snap-extras

commitde8f6fc5b13705e80efab2494fbae65cee6875ba authorRyan Trinkle <ryan.trinkle@gmail.com> dateTue 6 Feb 2018, 18:06 (9 years ago) parent6194f5a

2 files changed+16−13

compare with master

unifiedsplit

lib/snap-extras/src/Obelisk/Snap/Extras.hs+15 lib/snap/src/Obelisk/Snap.hs+1−13

lib/snap-extras/src/Obelisk/Snap/Extras.hs+15

@@ -8,6 +8,8 @@ module Obelisk.Snap.Extras

99import Control.Monad.IO.Class

1010import Data.ByteString (ByteString)

11+import Data.Monoid

12+import Data.String

1113import Snap.Core

1214import Snap.Util.FileServe

1315import System.Directory

@@ -35,3 +37,16 @@ serveFileIfExistsAs :: MonadSnap m => ByteString -> FilePath -> m ()

3537serveFileIfExistsAs mimeType f = do

3638 exists <- liftIO $ doesFileExist f

3739 if exists then serveFileAs mimeType f else pass

40+

41+-- | Only run the given handler when the connection is "secure" (i.e. made with HTTPS)

42+ensureSecure

43+ :: MonadSnap m

44+ => Int -- ^ The port where this server answers HTTPS requests

45+ -> m () -- ^ A handler to be run only when the connection is secure

46+ -> m ()

47+ensureSecure port h = do

48+ s <- getsRequest rqIsSecure

49+ if s then h else do

50+ uri <- getsRequest rqURI

51+ host <- getsRequest rqHostName --TODO: It might be better to use the canonical base of the server

52+ redirect $ "https://" <> host <> (if port == 443 then "" else ":" <> fromString (show port)) <> uri

lib/snap/src/Obelisk/Snap.hs+1−13

@@ -25,18 +25,6 @@ import System.FilePath

2525import Text.RawString.QQ

2626import Control.Monad.IO.Class

2727

28−

29−{- | Takes a port number and session handle to determine if what has been

30− - passed is an HTTPS Session. If not, it will request URI along with the name

31− - of host and return a HTTPS redirect. -}

32−ensureSecure :: Int -> Handler a b () -> Handler a b ()

33−ensureSecure port h = do

34− s <- getsRequest rqIsSecure

35− if s then h else do

36− uri <- getsRequest rqURI

37− host <- getsRequest rqHostName --TODO: It might be better to use the canonical base of the server

38− redirect $ "https://" <> host <> (if port == 443 then "" else ":" <> fromString (show port)) <> uri

39−

4028-- Data type for web app configuration

4129data AppConfig m

4230 = AppConfig { _appConfig_logo :: Diagram SVG

@@ -107,7 +95,7 @@ serveStaticIndex cfg = do

10795 -- Render and write html head and body to response

10896 writeLBS $ renderBS $ doctypehtml_ $ do

10997 head_ $ do

110− meta_ [charset_ "utf-8"] -- meta-data charset description

98+ meta_ [charset_ "utf-8"] -- meta-data charset description

11199 meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] -- meta-data viewport description

112100 _appConfig_extraHeadMarkup cfg -- any additional <head> html from 'AppConfig' type

113101 toHtmlRaw initialHead -- HtmlT monad wrapper