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
|
{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
module SessionID (
SessionID,
mkSessionID,
sessionLogFile,
withSessionID,
sessionIDUrl,
) where
import Serialization
import System.FilePath
import System.IO
import System.Directory
import Network.Wai.Handler.Warp (Port)
import Network.WebSockets hiding (Message)
import qualified Data.Aeson
import Data.Maybe
import Data.List
import Data.UUID
import Data.UUID.V4
import Control.Concurrent.STM
import Control.Exception
-- | A SessionID is the base name of the log file to use,
-- and may not contain any path information.
newtype SessionID = SessionID FilePath
deriving (Show, Eq, Ord, Generic)
instance ToJSON SessionID
instance FromJSON SessionID
instance WebSocketsData SessionID where
-- fromDataMessage = fromLazyByteString . fromDataMessage
fromLazyByteString b =
-- Down't trust a legal SessionID to be deserialized;
-- use smart constructor to verify it's legal.
let SessionID unverified = fromMaybe (error "bad SessionID serialization") (Data.Aeson.decode b)
in fromMaybe (error "illegal SessionID") (mkSessionID unverified)
toLazyByteString = Data.Aeson.encode
-- | Smart constructor that enforces legal SessionID contents.
--
-- The passed String can either be the bare SessionID, or it can be an URL
-- which ends with the SessionID.
mkSessionID :: String -> Maybe SessionID
mkSessionID s
| "http" `isPrefixOf` s = Just $ SessionID $ takeFileName s
| takeFileName s == s = Just $ SessionID s
| otherwise = Nothing
sessionLogFile :: FilePath -> SessionID -> FilePath
sessionLogFile dir (SessionID f) = dir </> "debug-me." ++ f ++ ".log"
-- | Allocate a new SessionID open a Handle to its log file.
--
-- A UUID is used, to avoid ever generating a SessionID that has been used
-- before.
withSessionID :: FilePath -> ((TVar Handle, SessionID) -> IO a) -> IO a
withSessionID dir a = do
createDirectoryIfMissing False dir
sid <- SessionID . toString <$> nextRandom
let f = sessionLogFile dir sid
-- File should not already exist, but just in case we get
-- spectacularly unlucky (or the RNG is broken..),
-- avoid overwriting a log, and try again.
exists <- doesFileExist f
if exists
then withSessionID dir a
else bracket (setup f) cleanup (go sid)
where
setup f = do
h <- openFile f WriteMode
hv <- newTVarIO h
return hv
cleanup hv = hClose =<< atomically (readTVar hv)
go sid hv = a (hv, sid)
type UrlString = String
sessionIDUrl :: SessionID -> String -> Port -> UrlString
sessionIDUrl (SessionID f) host port = "http://" ++ host ++ ":" ++ show port ++ "/" ++ f
|
