/
CoreUtils.hs
158 lines (122 loc) · 5.34 KB
/
CoreUtils.hs
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Snap.Extras.CoreUtils
( finishEarly
, badReq
, notFound
, serverError
, plainResponse
, jsonResponse
, jsResponse
, easyLog
, getParam'
, reqParam
, readParam
, readMayParam
, redirectReferer
, redirectRefererFunc
, dirify
, undirify
) where
-------------------------------------------------------------------------------
import Control.Monad
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Maybe
import Safe
import Snap.Core
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- | Discard anything after this and return given status code to HTTP
-- client immediately.
finishEarly :: MonadSnap m => Int -> ByteString -> m b
finishEarly code str = do
modifyResponse $ setResponseStatus code str
modifyResponse $ addHeader "Content-Type" "text/plain"
writeBS str
getResponse >>= finishWith
-------------------------------------------------------------------------------
-- | Finish early with error code 400
badReq :: MonadSnap m => ByteString -> m b
badReq = finishEarly 400
-------------------------------------------------------------------------------
-- | Finish early with error code 404
notFound :: MonadSnap m => ByteString -> m b
notFound = finishEarly 404
-------------------------------------------------------------------------------
-- | Finish early with error code 500
serverError :: MonadSnap m => ByteString -> m b
serverError = finishEarly 500
-------------------------------------------------------------------------------
-- | Mark response as 'text/plain'
plainResponse :: MonadSnap m => m ()
plainResponse = modifyResponse $ setHeader "Content-Type" "text/plain"
-------------------------------------------------------------------------------
-- | Mark response as 'application/json'
jsonResponse :: MonadSnap m => m ()
jsonResponse = modifyResponse $ setHeader "Content-Type" "application/json"
-------------------------------------------------------------------------------
-- | Mark response as 'application/javascript'
jsResponse :: MonadSnap m => m ()
jsResponse = modifyResponse $ setHeader "Content-Type" "application/javascript"
------------------------------------------------------------------------------
-- | Easier debug logging into error log. First argument is a
-- category/namespace and the second argument is anything that has a
-- 'Show' instance.
easyLog :: (Show t, MonadSnap m) => String -> t -> m ()
easyLog k v = logError . B.pack $ ("[Debug] " ++ k ++ ": " ++ show v)
-------------------------------------------------------------------------------
-- | Alternate version of getParam that considers empty string Nothing
getParam' :: MonadSnap m => ByteString -> m (Maybe ByteString)
getParam' = return . maybe Nothing f <=< getParam
where f "" = Nothing
f x = Just x
-------------------------------------------------------------------------------
-- | Require that a parameter is present or terminate early.
reqParam :: (MonadSnap m) => ByteString -> m ByteString
reqParam s = do
p <- getParam s
maybe (badReq $ B.concat ["Required parameter ", s, " is missing."]) return p
-------------------------------------------------------------------------------
-- | Read a parameter from request. Be sure it is readable if it's
-- there, or else this will raise an error.
readParam :: (MonadSnap m, Read a) => ByteString -> m (Maybe a)
readParam k = fmap (readNote "readParam failed" . B.unpack) `fmap` getParam k
-------------------------------------------------------------------------------
-- | Try to read a parameter from request. Computation may fail
-- because the param is not there, or because it can't be read.
readMayParam :: (MonadSnap m, Read a) => ByteString -> m (Maybe a)
readMayParam k = do
p <- getParam k
return $ readMay . B.unpack =<< p
------------------------------------------------------------------------------
-- | Redirects back to the refering page. If there is no Referer header, then
-- redirect to /.
redirectReferer :: MonadSnap m => m b
redirectReferer = redirectRefererFunc (fromMaybe "/")
------------------------------------------------------------------------------
-- | Redirects back to the refering page. If there is no Referer header, then
-- redirect to /.
redirectRefererFunc :: MonadSnap m => (Maybe ByteString -> ByteString) -> m b
redirectRefererFunc f = do
req <- getRequest
let referer = getHeader "Referer" req
redirect $ f referer
------------------------------------------------------------------------------
-- | If the current rqURI does not have a trailing slash, then redirect to the
-- same page with a slash added.
dirify :: MonadSnap m => m ()
dirify = do
uri <- withRequest (return . rqURI)
if B.length uri > 1 && B.last uri /= '/'
then redirect (uri `B.append` "/")
else return ()
------------------------------------------------------------------------------
-- | If the current rqURI has a trailing slash, then redirect to the same page
-- with no trailing slash.
undirify :: MonadSnap m => m ()
undirify = do
uri <- withRequest (return . rqURI)
if B.length uri > 1 && B.last uri == '/'
then redirect (B.init uri)
else return ()