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
|
{- WAI webapp
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, CPP #-}
module Utility.WebApp where
import Common
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Logger
import Control.Monad.IO.Class
import Network.HTTP.Types
import System.Log.Logger
import Data.ByteString.Lazy.UTF8
import Data.ByteString.Lazy
import Data.CaseInsensitive as CI
import Network.Socket
import Control.Exception
import Crypto.Random
import Data.Digest.Pure.SHA
import Data.ByteString.Lazy as L
localhost :: String
localhost = "localhost"
{- Runs a web browser on a given url.
-
- Note: The url *will* be visible to an attacker. -}
runBrowser :: String -> IO Bool
runBrowser url = boolSystem cmd [Param url]
where
#if MAC
cmd = "open"
#else
cmd = "xdg-open"
#endif
{- Binds to a socket on localhost, and runs a webapp on it.
-
- An IO action can also be run, to do something with the port number,
- such as start a web browser to view the webapp.
-}
runWebApp :: Application -> (PortNumber -> IO ()) -> IO ()
runWebApp app observer = do
sock <- localSocket
observer =<< socketPort sock
runSettingsSocket defaultSettings sock app
{- Binds to a local socket, selecting any free port.
-
- As a (very weak) form of security, only connections from
- localhost are accepted. -}
localSocket :: IO Socket
localSocket = do
addrs <- getAddrInfo (Just hints) (Just localhost) Nothing
go $ Prelude.head addrs
where
hints = defaultHints
{ addrFlags = [AI_ADDRCONFIG, AI_NUMERICSERV]
, addrSocketType = Stream
}
go addr = bracketOnError (open addr) close (use addr)
open addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
close = sClose
use addr sock = do
setSocketOption sock ReuseAddr 1
bindSocket sock (addrAddress addr)
listen sock maxListenQueue
return sock
{- Checks if debugging is actually enabled. -}
debugEnabled :: IO Bool
debugEnabled = do
l <- getRootLogger
return $ getLevel l <= Just DEBUG
{- WAI middleware that logs using System.Log.Logger at debug level.
-
- Recommend only inserting this middleware when debugging is actually
- enabled, as it's not optimised at all.
-}
httpDebugLogger :: Middleware
httpDebugLogger waiApp req = do
logRequest req
waiApp req
logRequest :: MonadIO m => Request -> m ()
logRequest req = do
liftIO $ debugM "WebApp" $ unwords
[ showSockAddr $ remoteHost req
, frombs $ requestMethod req
, frombs $ rawPathInfo req
--, show $ httpVersion req
--, frombs $ lookupRequestField "referer" req
, frombs $ lookupRequestField "user-agent" req
]
where
frombs v = toString $ fromChunks [v]
lookupRequestField :: CI Ascii -> Request -> Ascii
lookupRequestField k req = fromMaybe "" . lookup k $ requestHeaders req
{- Generates a 512 byte random token, suitable to be used for an
- authentication secret. -}
genRandomToken :: IO String
genRandomToken = do
g <- newGenIO :: IO SystemRandom
return $
case genBytes 512 g of
Left e -> error $ "failed to generate secret token: " ++ show e
Right (s, _) -> showDigest $ sha512 $ L.fromChunks [s]
|
