stuff changed, especially in auth. Authentication works for now.

app/Main.hs

@@ -78,6 +78,7 @@ app initState =
         productStockRefill :<|>
         productStockUpdate :<|>
         productList :<|>
+        productShortList :<|>
 
         buy :<|>
 

mateamt.cabal

@@ -85,6 +85,7 @@ library
                      , http-api-data
                      , bytestring
                      , base16-bytestring
+                     , base64-bytestring
                      , random-bytestring
                      , containers
                      , stm

src/API.hs

@@ -52,6 +52,8 @@ type MateAPI =
     :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] ()
   :<|> "product" :> "list" :> QueryParam "refine" ProductRefine
     :> Get '[JSON] [ProductOverview]
+  :<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine
+    :> Get '[JSON] [ProductShortOverview]
 
   :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
     :> Post '[JSON] PurchaseResult
@@ -87,6 +89,7 @@ type MateAPI =
   productStockRefillLink :<|>
   productStockUpdateLink :<|>
   productListLink :<|>
+  productShortListLink :<|>
 
   buyLink :<|>
 

src/Control/Product.hs

@@ -75,3 +75,10 @@ productList
 productList mrefine = do
   conn <- rsConnection <$> ask
   productOverviewSelect (fromMaybe AvailableProducts mrefine) conn
+
+productShortList
+  :: Maybe ProductRefine
+  -> MateHandler [ProductShortOverview]
+productShortList mrefine = do
+  conn <- rsConnection <$> ask
+  productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn

src/Model/Auth.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Arrows #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Model.Auth where
 
 import Servant
@@ -9,13 +10,10 @@ import Servant
 import Control.Arrow
 
 import Control.Monad (void)
-
 import Control.Monad.IO.Class (liftIO)
-
 import Control.Monad.Reader (ask)
 
 import Control.Concurrent (threadDelay)
-
 import Control.Concurrent.STM
 
 import Data.Profunctor.Product (p4, p5)
@@ -31,8 +29,10 @@ import qualified Data.Set as S
 
 import Data.Time.Clock
 
-import Data.ByteString (ByteString)
+import Data.ByteString as B (ByteString, drop)
 import Data.ByteString.Random
+import qualified Data.ByteString.Base64 as B64
+import qualified Data.ByteString.Base16 as B16
 
 import Opaleye hiding (null)
 import qualified Opaleye.Constant as C
@@ -81,7 +81,7 @@ initAuthData = mconcat
   , "auth_data_user    INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
   , "auth_data_method  INTEGER NOT NULL,"
   , "auth_data_comment TEXT    NOT NULL,"
-  , "auth_data_payload TEXT    NOT NULL"
+  , "auth_data_payload BYTEA   NOT NULL"
   , ")"
   ]
 
@@ -90,13 +90,13 @@ authDataTable :: Table
   , Field SqlInt4
   , Field SqlInt4
   , Field SqlText
-  , Field SqlText
+  , Field SqlBytea
   )
   ( Field SqlInt4
   , Field SqlInt4
   , Field SqlInt4
   , Field SqlText
-  , Field SqlText
+  , Field SqlBytea
   )
 authDataTable = table "auth_data" (
   p5
@@ -114,7 +114,7 @@ delayTime = 1 * 10 ^ (6 :: Int)
 
 
 generateRandomText :: IO T.Text
-generateRandomText = decodeUtf8 <$> random 23
+generateRandomText = decodeUtf8 <$> B64.encode <$> random 23
 
 
 selectAuthOverviews
@@ -122,7 +122,7 @@ selectAuthOverviews
   -> PGS.Connection
   -> MateHandler [AuthOverview]
 selectAuthOverviews uid conn = do
-  authData <- liftIO $ runSelect conn ( proc () -> do
+  authData <- liftIO $ runSelect conn (proc () -> do
     (adid, aduid, admethod, adcomment, adpayload) <-
       queryTable authDataTable -< ()
     restrict -< aduid .== C.constant uid
@@ -146,20 +146,24 @@ getUserAuthInfo
   -> PGS.Connection
   -> MateHandler AuthInfo
 getUserAuthInfo uid method conn = do
-  authdata <- liftIO $ do
+  authdata <- map (\(aid, auid, amethod, acomment, apayload) ->
+    (aid, auid, amethod, acomment, (decodeUtf8 $ B64.encode apayload))) <$>
+    (liftIO $ do
       void $ threadDelay delayTime
-    runSelect conn (
+      runSelect conn (proc () -> do
-      keepWhen (\(_, duid, dmethod, _, _) ->
+        (aid, auid, amethod, acomment, apayload) <-
-        duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method))
+          queryTable authDataTable -< ()
-          <<< queryTable authDataTable
+        restrict -<
+          auid .== C.constant uid .&& amethod .== C.constant (fromEnum method)
+        returnA -< (aid, auid, amethod, acomment, apayload)
         ) :: IO
             [ ( Int
               , Int
               , Int
               , T.Text
-            , T.Text
+              , ByteString
               )
-          ]
+            ])
   if null authdata
   then
     -- generate mock AuthInfo
@@ -189,7 +193,7 @@ putUserAuthInfo uid method comment payload conn =
       , C.constant uid
       , C.constant (fromEnum method)
       , C.constant comment
-      , C.constant payload
+      , C.constant (encodeUtf8 payload)
       )
       ]
     , iReturning = rReturning (\(adid, _, _, _, _) -> adid)
@@ -246,7 +250,7 @@ generateToken
   -> AuthResponse
   -> PGS.Connection
   -> MateHandler AuthResult
-generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
+generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse rawresponse) conn = do
   authData <- liftIO $ runSelect conn (
     keepWhen (\(_, auid, amethod, _, _) ->
       auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
@@ -256,14 +260,17 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
           , Int
           , Int
           , T.Text
-          , T.Text
+          , ByteString
           )
         ]
-  let userPayloads = map (\(_, _, _, _, payload) -> payload) authData
+  let userPayloads = map (\(_, _, _, _, payload) ->
+        (decodeUtf8 $ fst $ B16.decode $ B.drop 2 payload)) authData
+      response = rawresponse
       authResult = case method of
         PrimaryPass       -> validatePass response userPayloads
         SecondaryPass     -> validatePass response userPayloads
         ChallengeResponse -> validateChallengeResponse response userPayloads
+  liftIO $ print (response : userPayloads)
   if authResult
   then do
     token <- liftIO $ Token
@@ -279,7 +286,7 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
     validatePass provided presents =
       any (\present -> provided == present) presents
     validateChallengeResponse provided presents =
-      error "Validation of challnge response authentication not yet implemented"
+      error "Validation of challenge response authentication not yet implemented"
 
 
 insertToken
@@ -352,6 +359,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
   let mticket = S.filter (\st -> ticketId st == aticket) store
   case S.toList mticket of
     [ticket] -> do
+      liftIO $ putStrLn "there is a ticket..."
       now <- liftIO $ getCurrentTime
       liftIO $ threadDelay delayTime
       if now > ticketExpiry ticket
@@ -367,7 +375,8 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
 #else
         return Denied
 #endif
-      else
+      else do
+        liftIO $ putStrLn "...and it is valid"
         generateToken ticket hash conn
     _        -> do
       liftIO $ threadDelay delayTime

src/Model/Product.hs

@@ -228,12 +228,22 @@ productOverviewSelectSingle pid conn = do
 
 
 productShortOverviewSelect
-  :: PGS.Connection
+  :: ProductRefine
+  -> PGS.Connection
   -> MateHandler [ProductShortOverview]
-productShortOverviewSelect conn = do
+productShortOverviewSelect refine conn = do
   prods <- liftIO $ runSelect conn
     ( proc () -> do
         (i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
+        (a1, a2, a3, a4, a5) <-
+          limit 1 (
+            orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable))
+              -< ()
+        restrict -< a1 .== i1
+        restrict -< case refine of
+          AllProducts -> C.constant True
+          AvailableProducts -> a3 ./= C.constant (0 :: Int)
+          DepletedProducts -> a3 .== C.constant (0 :: Int)
         returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
     ) :: MateHandler
         [ ( Int