advanced linting

src/Control/Auth.hs

@@ -5,7 +5,7 @@ import Servant
 
 import Control.Monad (void)
 
-import Control.Monad.Reader (asks, ask)
+import Control.Monad.Reader (asks)
 import Control.Monad.IO.Class (liftIO)
 
 import Control.Concurrent.STM (readTVarIO)
@@ -19,21 +19,21 @@ authGet
   :: TicketRequest
   -> MateHandler AuthInfo
 authGet (TicketRequest uid method) =
-  getUserAuthInfo uid method =<< (asks rsConnection)
+  getUserAuthInfo uid method =<< asks rsConnection
 
 authSend
   :: AuthRequest
   -> MateHandler AuthResult
 authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
-  (liftIO . readTVarIO =<< rsTicketStore <$> ask) <*>
-  (asks rsConnection)
+  (liftIO . readTVarIO =<< asks rsTicketStore) <*>
+  asks rsConnection
   )
 
 authLogout
   :: Maybe (Int, AuthMethod)
   -> MateHandler ()
 authLogout (Just (muid, _)) =
-  processLogout muid =<< (asks rsConnection)
+  processLogout muid =<< asks rsConnection
 authLogout Nothing =
   throwError $ err401
     { errBody = "Unauthorized access"
@@ -43,7 +43,7 @@ authManageList
   :: Maybe (Int, AuthMethod)
   -> MateHandler [AuthOverview]
 authManageList (Just (uid, method)) =
-  if elem method [PrimaryPass, ChallengeResponse]
+  if method `elem` [PrimaryPass, ChallengeResponse]
   then do
     conn <- asks rsConnection
     selectAuthOverviews uid conn
@@ -61,7 +61,7 @@ authManageNewAuth
   -> AuthSubmit
   -> MateHandler Int
 authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
-  if elem method [PrimaryPass, ChallengeResponse]
+  if method `elem` [PrimaryPass, ChallengeResponse]
   then do
     conn <- asks rsConnection
     putUserAuthInfo uid asmethod ascomment aspayload conn
@@ -79,7 +79,7 @@ authManageDeleteAuth
   -> Int
   -> MateHandler ()
 authManageDeleteAuth (Just (uid, method)) adid =
-  if elem method [PrimaryPass, ChallengeResponse]
+  if method `elem` [PrimaryPass, ChallengeResponse]
   then do
     conn <- asks rsConnection
     ads <- selectAuthOverviews uid conn

src/Control/Buy.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE OverloadedStrings #-}
 module Control.Buy where
 
 import Control.Monad (void, foldM)
@@ -14,7 +13,7 @@ buy
   :: Maybe (Int, AuthMethod)
   -> [PurchaseDetail]
   -> MateHandler PurchaseResult
-buy (Just (auid, _)) pds = do
+buy auth pds = do
   conn <- asks rsConnection
   (missing, real) <- foldM (\(ms, rs) pd -> do
     mmiss <- checkProductAvailability pd conn
@@ -37,6 +36,8 @@ buy (Just (auid, _)) pds = do
     )
     0
     real
+  case auth of
+    Just (auid, _) -> do
       void $ addToUserBalance auid (-price) conn
       newBalance <- userBalanceSelect conn auid
       return $ PurchaseResult
@@ -45,32 +46,7 @@ buy (Just (auid, _)) pds = do
           else PurchaseOK
         )
         missing
-buy Nothing pds = do
-  conn <- asks rsConnection
-  (missing, real) <- foldM (\(ms, rs) pd -> do
-    mmiss <- checkProductAvailability pd conn
-    case mmiss of
-      Just miss -> return
-        ( (pd {purchaseDetailAmount = miss}):ms
-        , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
-        )
-      Nothing -> return
-        ( ms
-        , pd:rs
-        )
-    )
-    ([], [])
-    pds
-  mapM_
-    (`postBuyProductAmountUpdate` conn)
-    real
-  price <- foldM
-    (\total pd ->
-      fmap (+ total) (getLatestTotalPrice pd conn)
-    )
-    0
-    real
-  void $ insertNewJournalEntry (JournalSubmit "Cash purchase" price) conn
+    Nothing ->
       return $ PurchaseResult
         (PayAmount price)
         missing

src/Control/User.hs

@@ -50,7 +50,7 @@ userUpdate Nothing _ =
     { errBody = "No Authentication present."
     }
 userUpdate (Just (aid, method)) uds =
-  if elem method [PrimaryPass, ChallengeResponse]
+  if method `elem` [PrimaryPass, ChallengeResponse]
   then do
     now <- liftIO getCurrentTime
     conn <- asks rsConnection
@@ -102,7 +102,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) =
   then
     if auid /= target
     then
-      if elem method [PrimaryPass, ChallengeResponse]
+      if method `elem` [PrimaryPass, ChallengeResponse]
       then do
         conn <- asks rsConnection
         user <- userDetailsSelect auid conn

src/Model/Auth.hs

@@ -10,7 +10,7 @@ import Control.Arrow
 
 import Control.Monad (void)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Reader (ask)
+import Control.Monad.Reader (asks)
 
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.STM
@@ -283,8 +283,8 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
   else
     return Denied
   where
-    validatePass provided =
-      any (provided ==)
+    validatePass =
+      elem
     validateChallengeResponse _ _ =
       error "Validation of challenge response authentication not yet implemented"
 
@@ -334,7 +334,7 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
 
 newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
 newTicket ident method = do
-  store <- rsTicketStore <$> ask
+  store <- asks rsTicketStore
   rand1 <- liftIO generateRandomText
   rand2 <- liftIO $ case method of
     ChallengeResponse -> Just <$> generateRandomText

src/Model/Product.hs

@@ -128,21 +128,25 @@ productOverviewSelect refine conn = do
           )
         ]
   mapM
-    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
-      amounts <- liftIO $ runSelect conn
-        ( proc () -> do
+    (generateProductOverview conn)
+    prods
+
+queryAmounts
+  :: PGS.Connection
+  -> Int
+  -> IO [(Int, UTCTime, Int, Int, Bool)]
+queryAmounts conn pid = runSelect conn $ proc () -> do
   stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
     (queryTable amountTable) -< ()
-          restrict -< C.constant i1 .== a1
+  restrict -< C.constant pid .== a1
   returnA -< stuff
-          ) :: MateHandler
-              [ ( Int
-                , UTCTime
-                , Int
-                , Int
-                , Bool
-                )
-              ]
+
+generateProductOverview
+  :: PGS.Connection
+  -> (Int, Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe Text)
+  -> MateHandler ProductOverview
+generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9) = do
+  amounts <- liftIO $ queryAmounts conn i1
   (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
   let ii5 = snd $
         foldl
@@ -162,9 +166,6 @@ productOverviewSelect refine conn = do
         (Prelude.reverse amounts)
   return $ ProductOverview
     i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
-      )
-    prods
-
 
 productOverviewSelectSingle
   :: Int
@@ -189,41 +190,7 @@ productOverviewSelectSingle pid conn = do
           )
         ]
   head <$> mapM
-    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
-      amounts <- liftIO $ runSelect conn
-        ( proc () -> do
-          stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
-            (queryTable amountTable) -< ()
-          restrict -< C.constant i1 .== a1
-          returnA -< stuff
-          ) :: MateHandler
-              [ ( Int
-                , UTCTime
-                , Int
-                , Int
-                , Bool
-                )
-              ]
-      (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
-      let ii5 = snd $
-            foldl
-              (\(bef, van) (_, _, amo, _, ver) ->
-                if ver
-                then (amo, if amo < bef then van + (bef - amo) else van)
-                else (amo, van)
-                )
-              (0, 0)
-              (Prelude.reverse amounts)
-          ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
-            if ver
-            then (amo, tot)
-            else (amo, tot + max 0 (bef - amo))
-            )
-            (0, 0)
-            (Prelude.reverse amounts)
-      return $ ProductOverview
-        i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
-      )
+    (generateProductOverview conn)
     prods
 
 
@@ -259,20 +226,7 @@ productShortOverviewSelect refine conn = do
         ]
   mapM
     (\(i1, i2, i3, i4, _, _, _, _, _) -> do
-      amounts <- liftIO $ runSelect conn
-        ( proc () -> do
-          stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
-            (queryTable amountTable) -< ()
-          restrict -< C.constant i1 .== a1
-          returnA -< stuff
-          ) :: MateHandler
-              [ ( Int
-                , UTCTime
-                , Int
-                , Int
-                , Bool
-                )
-              ]
+      amounts <- liftIO $ queryAmounts conn i1
       (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
       return $ ProductShortOverview
         i1 i2 ii3 ii4 i3 i4

src/Model/User.hs

@@ -7,8 +7,6 @@ import Data.Time.Clock
 
 import Data.Profunctor.Product (p6)
 
-import Data.ByteString hiding (head, foldl)
-
 import Data.Int (Int64)
 
 import qualified Database.PostgreSQL.Simple as PGS
@@ -24,7 +22,6 @@ import qualified Opaleye.Constant as C
 
 import Types.User
 import Types.Refine
-import Types.Auth
 import Types.Reader
 
 initUser :: PGS.Query
@@ -70,7 +67,7 @@ userSelect
   -> PGS.Connection
   -> MateHandler [UserSummary]
 userSelect ref conn = do
-  today <- utctDay <$> (liftIO getCurrentTime)
+  today <- utctDay <$> liftIO getCurrentTime
   users <- liftIO $ runSelect conn (case ref of
       AllUsers -> selectTable userTable
       ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
@@ -89,7 +86,7 @@ userSelect ref conn = do
             )
           ]
   mapM
-    (\(i1, i2, i3, i4, i5, i6) -> return $
+    (\(i1, i2, _, _, _, i6) -> return $
       UserSummary i1 i2 i6
       )
     users