@@ -1,138 +0,0 @@
1−module Network.Wai.Middleware.ClientSession
2− ( clientsession
3− -- * Generating keys
4− , Word256
5− , defaultKeyFile
6− , getKey
7− , getDefaultKey
8− ) where
9−
10−import Prelude hiding (exp)
11−import Network.Wai
12−import Web.Encodings
13−import Data.List (partition)
14−import Data.Maybe (fromMaybe, mapMaybe)
15−import Web.ClientSession
16−import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime)
17−import Data.Time.LocalTime () -- Show instance of UTCTime
18−import Data.Time.Format (formatTime) -- Read instance of UTCTime
19−import System.Locale (defaultTimeLocale)
20−import Control.Monad (guard)
21−import qualified Data.ByteString.Char8 as B
22−import Control.Arrow (first)
23−
24−-- | Automatic encrypting and decrypting of client session data.
25−--
26−-- Using the clientsession package, this middleware handles automatic
27−-- encryption, decryption, checking, expiration and renewal of whichever
28−-- cookies you ask it to. For example, if you tell it to deal with the
29−-- cookie \"IDENTIFIER\", it will do the following:
30−--
31−-- * When you specify an \"IDENTIFIER\" value in your 'Response', it will
32−-- encrypt the value, along with the session expiration date and the
33−-- REMOTE_HOST of the user. It will then be set as a cookie on the client.
34−--
35−-- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will
36−-- decrypt it and check both the expiration date and the REMOTE_HOST. If
37−-- everything matches up, it will set the \"IDENTIFIER\" value in
38−-- 'hackHeaders'.
39−--
40−-- * If the client sent an \"IDENTIFIER\" and the application does not set
41−-- a new value, this will reset the cookie to a new expiration date. This
42−-- way, you do not have sessions timing out every 20 minutes.
43−--
44−-- As far as security: clientsesion itself handles hashing and encrypting
45−-- the data to make sure that the user can neither see not tamper with it.
46−clientsession :: [B.ByteString] -- ^ list of cookies to intercept
47− -> Word256 -- ^ encryption key
48− -> Int -- ^ minutes to live
49− -> ([(B.ByteString, B.ByteString)] -> Application)
50− -> Request
51− -> IO Response
52−clientsession cnames key minutesToLive app env = do
53− let hs = requestHeaders env
54− initCookiesRaw :: B.ByteString
55− initCookiesRaw = fromMaybe B.empty $ lookup Cookie hs
56− nonCookies :: [(RequestHeader, B.ByteString)]
57− nonCookies = filter (\(x, _) -> x /= Cookie) hs
58− initCookies :: [(B.ByteString, B.ByteString)]
59− initCookies = parseCookies initCookiesRaw
60− cookies, interceptCookies :: [(B.ByteString, B.ByteString)]
61− (interceptCookies, cookies) = partition (\(x, _) -> x `elem` cnames)
62− initCookies
63− cookiesRaw, remoteHost' :: B.ByteString
64− cookiesRaw = B.concat $ combineCookies cookies
65− remoteHost' = remoteHost env
66− print ("intercept", cnames, interceptCookies)
67− now <- getCurrentTime
68− let convertedCookies :: [(B.ByteString, B.ByteString)]
69− convertedCookies =
70− mapMaybe (decodeCookie key now remoteHost') interceptCookies
71− let env' = env { requestHeaders =
72− (Cookie, cookiesRaw)
73− -- FIXME not sure how I feel about the next line
74− : filter (\(x, _) -> x == Cookie)
75− (requestHeaders env)
76− ++ nonCookies
77− }
78− res <- app convertedCookies env'
79− let interceptHeaders, responseHeaders' :: [(ResponseHeader, B.ByteString)]
80− (interceptHeaders, responseHeaders') =
81− partition (\(x, _) -> responseHeaderToBS x `elem` cnames)
82− $ responseHeaders res
83− interceptHeaders' :: [(B.ByteString, B.ByteString)]
84− interceptHeaders' = map (first responseHeaderToBS) interceptHeaders
85− let timeToLive :: Int
86− timeToLive = minutesToLive * 60
87− let exp = fromIntegral timeToLive `addUTCTime` now
88− let formattedExp = B.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp
89− let oldCookies :: [(B.ByteString, B.ByteString)]
90− oldCookies = filter
91− (\(k, _) -> k `notElem` map fst interceptHeaders')
92− convertedCookies
93− let newCookies = map (setCookie key exp formattedExp remoteHost') $
94− oldCookies ++ interceptHeaders'
95− print ("cookies", oldCookies, newCookies, cookiesRaw)
96− let res' = res { responseHeaders = newCookies ++ responseHeaders' }
97− return res'
98−
99−combineCookies :: [(B.ByteString, B.ByteString)] -> [B.ByteString]
100−combineCookies [] = []
101−combineCookies ((k, v):rest) = k : B.singleton '=' : v : B.pack "; "
102− : combineCookies rest
103−setCookie :: Word256
104− -> UTCTime -- ^ expiration time
105− -> B.ByteString -- ^ formatted expiration time
106− -> B.ByteString -- ^ remote host
107− -> (B.ByteString, B.ByteString)
108− -> (ResponseHeader, B.ByteString)
109−setCookie key exp fexp rhost (cname, cval) =
110− (SetCookie, B.concat
111− [ cname
112− , B.singleton '='
113− , B.pack $ encrypt key $ B.pack $ show $ ACookie exp rhost cval
114− , B.pack "; path=/; expires="
115− , fexp
116− ])
117−
118−data ACookie = ACookie UTCTime B.ByteString B.ByteString
119− deriving (Show, Read)
120−
121−decodeCookie :: Word256 -- ^ key
122− -> UTCTime -- ^ current time
123− -> B.ByteString -- ^ remote host field
124− -> (B.ByteString, B.ByteString) -- ^ cookie pair
125− -> Maybe (B.ByteString, B.ByteString)
126−decodeCookie key now rhost (cname, encrypted) = do
127− decrypted <- decrypt key $ B.unpack encrypted
128− (ACookie exp rhost' val) <- mread $ B.unpack decrypted
129− guard $ exp > now
130− guard $ rhost' == rhost
131− guard $ not $ B.null val
132− return (cname, val)
133−
134−mread :: (Monad m, Read a) => String -> m a
135−mread s =
136− case reads s of
137− [] -> fail $ "Reading of " ++ s ++ " failed"
138− ((x, _):_) -> return x