| 1 | {-# LANGUAGE CApiFFI #-} |
| 2 | |
| 3 | -- | The anonymous cookie that names a visitor's list. |
| 4 | module Todo.Cookie |
| 5 | ( cookieName |
| 6 | , newToken |
| 7 | , readToken |
| 8 | , setCookie |
| 9 | ) where |
| 10 | |
| 11 | import Control.Monad (when) |
| 12 | import Data.ByteString (ByteString) |
| 13 | import Data.ByteString qualified as BS |
| 14 | import Data.ByteString.Builder qualified as B |
| 15 | import Data.ByteString.Internal qualified as BSI |
| 16 | import Data.ByteString.Lazy qualified as BL |
| 17 | import Data.Char (isHexDigit, isLower, isDigit) |
| 18 | import Data.Text (Text) |
| 19 | import Data.Text.Encoding qualified as T |
| 20 | import Data.Word (Word8) |
| 21 | import Foreign.C.Types (CSize (..), CUInt (..)) |
| 22 | import Foreign.Ptr (Ptr, plusPtr) |
| 23 | import System.Posix.Types (CSsize (..)) |
| 24 | import Web.Cookie |
| 25 | |
| 26 | cookieName :: ByteString |
| 27 | cookieName = "todo_list" |
| 28 | |
| 29 | -- | Bytes of randomness in a token: 256 bits, written as 64 hex digits. |
| 30 | tokenBytes :: Int |
| 31 | tokenBytes = 32 |
| 32 | |
| 33 | foreign import capi unsafe "sys/random.h getrandom" |
| 34 | c_getrandom :: Ptr Word8 -> CSize -> CUInt -> IO CSsize |
| 35 | |
| 36 | -- | A fresh token from the kernel's CSPRNG (getrandom(2), so no file |
| 37 | -- under @/dev@ has to be visible to a sandboxed instance). |
| 38 | newToken :: IO Text |
| 39 | newToken = do |
| 40 | bytes <- BSI.create tokenBytes (fill tokenBytes) |
| 41 | pure . T.decodeLatin1 . BL.toStrict . B.toLazyByteString $ B.byteStringHex bytes |
| 42 | where |
| 43 | fill 0 _ = pure () |
| 44 | fill n p = do |
| 45 | got <- c_getrandom p (fromIntegral n) 0 |
| 46 | -- A negative answer is EINTR or similar: just ask again. |
| 47 | when (got < 0) $ fill n p |
| 48 | when (got > 0) $ fill (n - fromIntegral got) (p `plusPtr` fromIntegral got) |
| 49 | |
| 50 | -- | The token in a request's @Cookie@ header, if it has the shape of one |
| 51 | -- this app mints. Anything else, garbled or not, is treated as absent. |
| 52 | readToken :: Maybe ByteString -> Maybe Text |
| 53 | readToken header = do |
| 54 | value <- lookup cookieName . parseCookies =<< header |
| 55 | let ok c = isHexDigit c && (isDigit c || isLower c) |
| 56 | if BS.length value == 2 * tokenBytes && BS.all (ok . BSI.w2c) value |
| 57 | then Just (T.decodeLatin1 value) |
| 58 | else Nothing |
| 59 | |
| 60 | -- | The @Set-Cookie@ value for a token. @secure@ is set when the app is |
| 61 | -- served over https. |
| 62 | setCookie :: Bool -> Text -> ByteString |
| 63 | setCookie secure token = |
| 64 | BL.toStrict . B.toLazyByteString . renderSetCookie $ |
| 65 | defaultSetCookie |
| 66 | { setCookieName = cookieName |
| 67 | , setCookieValue = T.encodeUtf8 token |
| 68 | , setCookiePath = Just "/" |
| 69 | , setCookieMaxAge = Just (400 * 24 * 60 * 60) |
| 70 | , setCookieHttpOnly = True |
| 71 | , setCookieSecure = secure |
| 72 | , setCookieSameSite = Just sameSiteLax |
| 73 | } |
| 74 | |
amadan