more playing

src/Control/Auth.hs

@@ -21,7 +21,7 @@ import Data.Text.Encoding
 
 import Types
 import Model
-import Util
+import Util.Random
 
 authGet
   :: TicketRequest

src/Model/Auth.hs

@@ -38,7 +38,7 @@ import Opaleye hiding (null)
 import Types.Auth
 import Types.Reader
 import Classes
-
+import Util.Random
 
 initToken :: PGS.Query
 initToken = mconcat
@@ -51,12 +51,12 @@ initToken = mconcat
   ]
 
 tokenTable :: Table
-  ( Field SqlText
+  ( Field SqlBytea
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
   )
-  ( Field SqlText
+  ( Field SqlBytea
   , Field SqlInt4
   , Field SqlTimestamptz
   , Field SqlInt4
@@ -110,10 +110,6 @@ delayTime :: Int
 delayTime = 1 * 10 ^ (6 :: Int)
 
 
-generateRandomText :: IO T.Text
-generateRandomText = decodeUtf8 . B64.encode <$> random 23
-
-
 selectAuthOverviews
   :: Int                        -- ^ User ID
   -> PGS.Connection             -- ^ Connection Handler
@@ -160,9 +156,9 @@ getUserAuthInfo uid method conn = do
   then
     -- generate mock AuthInfo
     liftIO $ do
-      rand1 <- generateRandomText
+      rand1 <- decodeUtf8 <$> randomString
       rand2 <- case method of
-        ChallengeResponse -> Just <$> generateRandomText
+        ChallengeResponse -> Just . decodeUtf8 <$> randomString
         _                 -> return Nothing
       return $ AuthInfo rand2 (AuthTicket rand1)
   else
@@ -212,7 +208,7 @@ validateToken header conn = do
   tokens <- liftIO $ map fromDatabase <$> runSelect conn (
     proc () -> do
       stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
-      restrict -< toFields (decodeUtf8 header) .== tstr
+      restrict -< toFields header .== tstr
       returnA -< stuff
     )
   case tokens of
@@ -221,7 +217,7 @@ validateToken header conn = do
       if diffUTCTime stamp now_ > 0
       then return $ Just (uid, method)
       else do
-        void $ deleteToken (decodeUtf8 header) conn
+        void $ deleteToken header conn
         liftIO $ threadDelay delayTime
         throwError $ err401
           { errBody = "Your token expired!"
@@ -256,7 +252,7 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   if authResult
   then do
     token <- liftIO $ Token
-      <$> generateRandomText
+      <$> (decodeUtf8 <$> randomString)
       <*> pure tuid
       <*> (addUTCTime (23*60) <$> getCurrentTime)
       <*> pure method
@@ -274,13 +270,13 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
 insertToken
   :: Token
   -> PGS.Connection
-  -> MateHandler T.Text
+  -> MateHandler ByteString
 insertToken (Token tString tUser tExpiry tMethod) conn =
   fmap head $ liftIO $ runInsert_ conn $ Insert
     { iTable = tokenTable
     , iRows =
       [
-      ( toFields tString
+      ( toFields (encodeUtf8 tString)
       , toFields tUser
       , toFields tExpiry
       , toFields (fromEnum tMethod)
@@ -292,7 +288,7 @@ insertToken (Token tString tUser tExpiry tMethod) conn =
 
 
 deleteToken
-  :: T.Text
+  :: ByteString
   -> PGS.Connection
   -> Handler Int64
 deleteToken tstr conn =
@@ -328,9 +324,9 @@ deleteOldTokens now_ conn = runDelete_ conn $ Delete
 newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
 newTicket ident method = do
   store <- asks rsTicketStore
-  rand1 <- liftIO generateRandomText
+  rand1 <- liftIO (decodeUtf8 <$> randomString)
   rand2 <- liftIO $ case method of
-    ChallengeResponse -> Just <$> generateRandomText
+    ChallengeResponse -> Just . decodeUtf8 <$> randomString
     _                 -> return Nothing
   later <- liftIO (addUTCTime 23 <$> getCurrentTime)
   let ticket = Ticket

src/Util.hs

@@ -155,6 +155,3 @@ sendNotification mail = do
     else
       print ("Warning: sending notification failed: Sendmail not present!"
         :: String)
-
-randomString :: IO BS.ByteString
-randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)

src/Util/Random.hs

@@ -0,0 +1,8 @@
+module Util.Random where
+
+import qualified Data.ByteString as BS
+
+import System.Random.Stateful (uniformByteStringM, newIOGenM, mkStdGen)
+
+randomString :: IO BS.ByteString
+randomString = uniformByteStringM 32 =<< newIOGenM (mkStdGen 23)