@@ -0,0 +1,78 @@
1+module Random.Token
2+ ( Token
3+ , tokenToAscii
4+ , tokenToText
5+ , asciiToToken
6+ , textToToken
7+#ifndef ghcjs_HOST_OS
8+ , generateToken
9+#endif
10+ ) where
11+
12+import Control.DeepSeq
13+import Data.Aeson
14+import Data.Bifunctor
15+import Data.ByteString as BS
16+import Data.ByteString.Base64.URL as B64
17+import Data.List as L
18+import Data.Text as T
19+import Data.Text.Encoding as T
20+import Data.Typeable
21+import Test.QuickCheck.Arbitrary
22+import Web.HttpApiData
23+
24+#ifndef ghcjs_HOST_OS
25+import Crypto.Random as R
26+import Database.PostgreSQL.Simple.FromField
27+import Database.PostgreSQL.Simple.ToField
28+#endif
29+
30+-- | 16 bytes lenght random value parametrized by label.
31+newtype Token (a :: k) = Token ByteString
32+ deriving (Ord, Eq, Show, NFData)
33+
34+type role Token nominal
35+
36+instance Arbitrary (Token a) where
37+ arbitrary = fmap (Token . BS.pack) $ sequence $ L.replicate 16 arbitrary
38+
39+instance FromJSON (Token a) where
40+ parseJSON v = do
41+ t <- parseJSON v
42+ either fail return $ textToToken t
43+
44+instance ToJSON (Token a) where
45+ toJSON = toJSON . tokenToText
46+
47+#ifndef ghcjs_HOST_OS
48+instance forall a. (Typeable (Token a), Typeable a) => FromField (Token a) where
49+ fromField fld bs = do
50+ t <- fromField fld bs
51+ case textToToken t of
52+ Left e -> returnError ConversionFailed fld e
53+ Right a -> return a
54+
55+instance ToField (Token a) where
56+ toField = toField . tokenToText
57+
58+generateToken :: (MonadRandom m) => m (Token a)
59+generateToken = Token <$> R.getRandomBytes 16
60+#endif
61+
62+instance FromHttpApiData (Token a) where
63+ parseQueryParam = first T.pack . textToToken
64+
65+instance ToHttpApiData (Token a) where
66+ toQueryParam = tokenToText
67+
68+tokenToAscii :: Token a -> ByteString
69+tokenToAscii (Token bs) = B64.encode bs
70+
71+tokenToText :: Token a -> Text
72+tokenToText = T.decodeUtf8 . tokenToAscii
73+
74+asciiToToken :: ByteString -> Either String (Token a)
75+asciiToToken bs = Token <$> B64.decode bs
76+
77+textToToken :: Text -> Either String (Token a)
78+textToToken = asciiToToken . T.encodeUtf8