git.iko.soy/typeable/random-token
on master help sign in
typeable/random-token/src/Random/Token.hs
87 lines 2.2 kB history raw
1{-# LANGUAGE CPP #-}
2module Random.Token
3 ( Token
4 , tokenToAscii
5 , tokenToText
6 , asciiToToken
7 , textToToken
8 , unsafeCoerceToken
9 , tokenWithContents
10#ifndef ghcjs_HOST_OS
11 , generateToken
12#endif
13 ) where
15import Control.DeepSeq
16import Data.Aeson
17import Data.Bifunctor
18import Data.ByteString as BS
19import Data.ByteString.Base64.URL as B64
20import Data.List as L
21import Data.Text as T
22import Data.Text.Encoding as T
23import Data.Typeable
24import Test.QuickCheck.Arbitrary
25import Web.HttpApiData
28#ifndef ghcjs_HOST_OS
29import Crypto.Random as R
30import Database.PostgreSQL.Simple.FromField
31import Database.PostgreSQL.Simple.ToField
32#endif
34-- | 16 bytes lenght random value parametrized by label.
35newtype Token (a :: k) = Token ByteString
36 deriving (Ord, Eq, Show, NFData)
38instance Arbitrary (Token a) where
39 arbitrary = fmap (Token . BS.pack) $ sequence $ L.replicate 16 arbitrary
41instance FromJSON (Token a) where
42 parseJSON v = do
43 t <- parseJSON v
44 either fail return $ textToToken t
46instance ToJSON (Token a) where
47 toJSON = toJSON . tokenToText
49#ifndef ghcjs_HOST_OS
50instance forall a. (Typeable (Token a), Typeable a) => FromField (Token a) where
51 fromField fld bs = do
52 t <- fromField fld bs
53 case textToToken t of
54 Left e -> returnError ConversionFailed fld e
55 Right a -> return a
57instance ToField (Token a) where
58 toField = toField . tokenToText
60generateToken :: (MonadRandom m) => m (Token a)
61generateToken = Token <$> R.getRandomBytes 16
63#endif
65instance FromHttpApiData (Token a) where
66 parseQueryParam = first T.pack . textToToken
68instance ToHttpApiData (Token a) where
69 toQueryParam = tokenToText
71tokenToAscii :: Token a -> ByteString
72tokenToAscii (Token bs) = B64.encode bs
74tokenToText :: Token a -> Text
75tokenToText = T.decodeUtf8 . tokenToAscii
77asciiToToken :: ByteString -> Either String (Token a)
78asciiToToken bs = Token <$> B64.decode bs
80textToToken :: Text -> Either String (Token a)
81textToToken = asciiToToken . T.encodeUtf8
83tokenWithContents :: Text -> Token a
84tokenWithContents = Token . T.encodeUtf8
86unsafeCoerceToken :: Token a -> Token b
87unsafeCoerceToken (Token a) = Token a