Merge pull request #142 from PrivateStorageio/hlint-pass

Fix most compiler warnings; add several TODO comments.

PaymentServer.cabal

@@ -52,21 +52,21 @@ library
                      , servant-prometheus
                      , mtl
   default-language:    Haskell2010
-  ghc-options:       -Wmissing-import-lists -Wunused-imports
+  ghc-options:        -Werror -Wall -Wno-name-shadowing -Wno-orphans -Wno-error=unused-do-bind
   pkgconfig-depends: libchallenge_bypass_ristretto_ffi
 
 executable PaymentServer-exe
   hs-source-dirs:      app
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
+  ghc-options:         -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , PaymentServer
   default-language:    Haskell2010
 
 executable PaymentServer-generate-key
   hs-source-dirs:      generate-key
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
+  ghc-options:         -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , text
                      , PaymentServer
@@ -75,7 +75,7 @@ executable PaymentServer-generate-key
 executable PaymentServer-get-public-key
   hs-source-dirs:      get-public-key
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
+  ghc-options:         -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , text
                      , optparse-applicative
@@ -85,7 +85,7 @@ executable PaymentServer-get-public-key
 executable PaymentServer-complete-payment
   hs-source-dirs:      complete-payment
   main-is:             Main.hs
-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
+  ghc-options:         -Werror -threaded -rtsopts -with-rtsopts=-N
   build-depends:       base
                      , time
                      , text
@@ -132,6 +132,7 @@ test-suite PaymentServer-tests
                      , stripe-core
                      , PaymentServer
   default-language: Haskell2010
+  ghc-options: -Wall -Wno-name-shadowing
 
 source-repository head
   type:     git

complete-payment/Main.hs

@@ -40,8 +40,6 @@ import Options.Applicative
   ( Parser
   , ParserInfo
   , strOption
-  , option
-  , auto
   , long
   , help
   , showDefault

generate-key/Main.hs

@@ -3,17 +3,11 @@ module Main
   ( main
   ) where
 
-import Prelude hiding
-  ( putStrLn
-  )
-
-import Data.Text.IO
-  ( putStrLn
-  )
+import qualified Data.Text.IO as TIO
 
 import PaymentServer.Ristretto
   ( randomSigningKey
   )
 
 main :: IO ()
-main = randomSigningKey >>= putStrLn
+main = randomSigningKey >>= TIO.putStrLn

get-public-key/Main.hs

@@ -3,15 +3,7 @@ module Main
   ( main
   ) where
 
-import Prelude hiding
-  ( putStrLn
-  , getLine
-  )
-
-import Data.Text.IO
-  ( putStrLn
-  , getLine
-  )
+import qualified Data.Text.IO as TIO
 
 import Options.Applicative
   ( ParserInfo
@@ -37,4 +29,4 @@ opts = info (pure () <**> helper)
 
 main :: IO ()
 main =
-  execParser opts >> getLine >>= getPublicKey >>= putStrLn
+  execParser opts >> TIO.getLine >>= getPublicKey >>= TIO.putStrLn

src/PaymentServer/Main.hs

@@ -110,7 +110,6 @@ import Options.Applicative
 import System.Exit
   ( exitFailure
   )
-import Data.Semigroup ((<>))
 import qualified Data.Text.IO as TIO
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as Char8
@@ -264,6 +263,7 @@ main = do
     logEndpoint (endpoint config)
     run app
 
+getPortNumber :: Endpoint -> Port
 getPortNumber (TCPEndpoint portNumber) = portNumber
 getPortNumber (TLSEndpoint portNumber _ _ _) = portNumber
 
@@ -272,7 +272,7 @@ getRunner endpoint =
   let
     onException :: Maybe Request -> SomeException -> IO ()
     onException _ exc = do
-      print "onException"
+      print ("onException" :: Text)
       print exc
       return ()
     onExceptionResponse :: SomeException -> Response
@@ -310,12 +310,12 @@ getApp config =
         (Ristretto, Just keyPath) -> do
           key <- TIO.readFile keyPath
           return $ Right $ ristrettoIssue key
-        _ -> return $ Left "invalid options"
+        _ -> return $ Left ("invalid options" :: Text)
     getDatabase ServerConfig{ database, databasePath } =
       case (database, databasePath) of
         (Memory, Nothing) -> Right memory
         (SQLite3, Just path) -> Right (sqlite path)
-        _ -> Left "invalid options"
+        _ -> Left ("invalid options" :: Text)
 
     stripeConfig ServerConfig
       { stripeKeyPath
@@ -339,7 +339,7 @@ getApp config =
   in do
     issuer <- getIssuer config
     case issuer of
-      Left err -> do
+      Left err -> do -- XXX shae turn this into a monad instead of a stairstep
         print err
         exitFailure
       Right issuer ->

src/PaymentServer/Persistence.hs

@@ -71,7 +71,7 @@ instance Exception PaymentError
 instance Eq PaymentError where
   AlreadyPaid == AlreadyPaid = True
   PaymentFailed self == PaymentFailed other = show self == show other
-  self == other = False
+  _self == _other = False
 
 -- | Reasons that a voucher cannot be redeemed.
 data RedeemError =
@@ -181,7 +181,7 @@ data VoucherDatabaseState =
   | SQLiteDB { connect :: IO Sqlite.Connection }
 
 instance VoucherDatabase VoucherDatabaseState where
-  payForVoucher MemoryDB{ paid = paidRef, redeemed = redeemed } voucher pay = do
+  payForVoucher MemoryDB{ paid = paidRef } voucher pay = do
     -- Surely far from ideal...
     paid <- readIORef paidRef
     if Set.member voucher paid
@@ -237,6 +237,8 @@ instance VoucherDatabase VoucherDatabaseState where
 
       transformBusy (Sqlite.SQLError Sqlite.ErrorBusy _ _) =
         return . Left $ DatabaseUnavailable
+      -- XXX things went poorly, should we handle with more detail?
+      transformBusy panic = error $ "redeemVoucherHelper got bad input " <> show panic
 
 
 -- | Look up the voucher, counter tuple which previously performed a
@@ -369,7 +371,7 @@ insertVoucher dbConn voucher pay =
           Right _ -> do
             Sqlite.execute dbConn "INSERT INTO vouchers (name, charge_id) VALUES (?, ?)" (voucher, Nothing :: Maybe Text)
             return result
-          Left err ->
+          Left _err ->
             return result
 
 -- | Mark the given voucher as having been redeemed (with the given
@@ -392,6 +394,7 @@ sqlite path =
       let exec = Sqlite.execute_ dbConn
       exec "PRAGMA busy_timeout = 60000"
       exec "PRAGMA foreign_keys = ON"
+      -- XXX handle any upgrade failures here!
       Sqlite.withExclusiveTransaction dbConn (upgradeSchema latestVersion dbConn)
       return dbConn
 
@@ -494,7 +497,7 @@ upgradeSchema targetVersion conn = do
         oneStep :: [Sqlite.Query] -> IO [()]
         oneStep = mapM $ Sqlite.execute_ conn
       in do
-        mapM oneStep upgrades
+        mapM_ oneStep upgrades
         return $ Right ()
 
 

src/PaymentServer/Processors/Stripe.hs

@@ -76,17 +76,14 @@ import Servant.API
   ( Header
   , ReqBody
   , JSON
-  , OctetStream
-  , PlainText
   , Post
   , Accept(contentType)
   , MimeUnrender(mimeUnrender)
   , (:>)
   )
 import Web.Stripe.Event
-  ( Event(Event, eventId, eventType, eventData)
-  , EventId(EventId)
-  , EventType(ChargeSucceededEvent, CheckoutSessionCompleted, PaymentIntentCreated)
+  ( Event(Event, eventType, eventData)
+  , EventType(CheckoutSessionCompleted)
   , EventData(ChargeEvent, CheckoutSessionEvent)
   )
 
@@ -109,8 +106,7 @@ import Web.Stripe.Charge
   , TokenId(TokenId)
   )
 import Web.Stripe.Client
-  ( StripeConfig(StripeConfig, secretKey)
-  , StripeKey(StripeKey)
+  ( StripeConfig
   )
 import Web.Stripe
   ( stripe
@@ -130,7 +126,6 @@ import PaymentServer.Persistence
   , ProcessorResult
   )
 import Data.Data (Typeable)
-import Servant.API.ContentTypes (AcceptHeader(AcceptHeader))
 
 data Acknowledgement = Ok deriving (Eq, Show)
 
@@ -164,8 +159,8 @@ getVoucher Event{eventData=(ChargeEvent charge)} =
   voucherFromMetadata . chargeMetaData $ charge
   where
     voucherFromMetadata (MetaData []) = Nothing
-    voucherFromMetadata (MetaData (("Voucher", value):xs)) = Just value
-    voucherFromMetadata (MetaData (x:xs)) = voucherFromMetadata (MetaData xs)
+    voucherFromMetadata (MetaData (("Voucher", value):_)) = Just value
+    voucherFromMetadata (MetaData (_:xs)) = voucherFromMetadata (MetaData xs)
 getVoucher _ = Nothing
 
 chargeServer :: VoucherDatabase d => StripeConfig -> d -> Server ChargesAPI
@@ -215,7 +210,7 @@ webhookServer WebhookConfig { webhookConfigKey } d (Just signatureText) payload
               -- should be able to indicate error I guess.
               _ <- liftIO . payForVoucher d v . return . Right $ ()
               return Ok
-        Right event@Event { eventType } ->
+        Right Event { eventType } ->
           throwError . jsonErr status400 . pack $ "unsupported event type " ++ show eventType
 
 -- | Browser facing API that takes token, voucher and a few other information
@@ -280,8 +275,7 @@ charge stripeConfig d (Charges token voucher 650 USD) = do
       throwError $ voucherAlreadyPaid "Payment for voucher already supplied"
 
     Left (PaymentFailed (StripeError { errorType = errorType, errorMsg = msg })) -> do
-      liftIO $ print "Stripe createCharge failed:"
-      liftIO $ print msg
+      liftIO $ print $ "Stripe createCharge failed: " <> msg
       let err = errorForStripe errorType ( Data.Text.concat [ "Stripe charge didn't succeed: ", msg ])
       throwError err
 
@@ -336,6 +330,7 @@ charge stripeConfig d (Charges token voucher 650 USD) = do
 charge _ _ (Charges _ _ 650 _) = throwError (jsonErr status400 "Unsupported currency")
 -- The wrong amount
 charge _ _ (Charges _ _ _ USD) = throwError (jsonErr status400 "Incorrect charge amount")
+charge badInput1 _badInput2 badInput3 = error $ mconcat ["charge got unexpected input : ", show badInput1, " ", "some VoucherDatabase value", " ", show badInput3]
 
 jsonErr :: Status -> Text -> ServerError
 jsonErr (Status statusCode statusMessage) detail = ServerError

src/PaymentServer/Redemption.hs

@@ -17,10 +17,6 @@ module PaymentServer.Redemption
   , redemptionServer
   ) where
 
-import Prelude hiding
-  ( concat
-  )
-
 import GHC.Generics
   ( Generic
   )
@@ -39,8 +35,8 @@ import Control.Monad.IO.Class
 import Data.Text
   ( Text
   , pack
-  , concat
   )
+import qualified Data.Text as Text
 import Data.Text.Encoding
   ( encodeUtf8
   )
@@ -176,6 +172,7 @@ instance FromJSON Result where
 
 type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
 
+jsonErr :: ToJSON a => ServerError -> a -> ServerError
 jsonErr err reason = err
   { errBody = encode reason
   , errHeaders = [ ("Content-Type", "application/json;charset=utf-8") ]
@@ -198,7 +195,7 @@ retry op =
     numRetries = totalRetryDuration `div` perRetryDelay
 
     policy = constantDelay (perRetryDelay * 1000) <> limitRetries numRetries
-    shouldRetry status value =
+    shouldRetry _status value =
       case value of
         Left NotPaid -> return True
         _ -> return False
@@ -290,4 +287,4 @@ signaturesIssued
 -- be used as an identifier for this exact sequence of tokens.
 fingerprintFromTokens :: [BlindedToken] -> Fingerprint
 fingerprintFromTokens =
-  pack . show . hashWith SHA3_512 . encodeUtf8 . concat
+  pack . show . hashWith SHA3_512 . encodeUtf8 . Text.concat

src/PaymentServer/Server.hs

@@ -52,9 +52,6 @@ import PaymentServer.Metrics
   ( MetricsAPI
   , metricsServer
   )
-import PaymentServer.Issuer
-  ( Issuer
-  )
 import PaymentServer.Persistence
   ( VoucherDatabase
   )

test/FakeStripe.hs

@@ -18,15 +18,6 @@ import Data.ByteString.Lazy
    ( ByteString
    )
 
-import Data.Time.Clock
-  ( UTCTime(UTCTime)
-  , secondsToDiffTime
-  )
-
-import Data.Time.Calendar
-  ( Day(ModifiedJulianDay)
-  )
-
 import Network.HTTP.Types
   ( status200
   , status400
@@ -183,11 +174,11 @@ aCharge = [r|
 
 -- Accept a charge creation and respond in the affirmative.
 chargeOkay :: Application
-chargeOkay req respond =
+chargeOkay _req respond =
   respond . responseLBS status200 [] $ aCharge
 
 chargeFailed :: ByteString -> Application
-chargeFailed stripeResponse req respond =
+chargeFailed stripeResponse _req respond =
   respond . responseLBS status400 [] $ stripeResponse
 
 -- Pass a Stripe-flavored configuration for a running Wai application to a

test/Metrics.hs

@@ -16,9 +16,7 @@ import Test.Tasty
   )
 
 import Test.Tasty.HUnit
-  ( testCase
-  , assertEqual
-  )
+  ( testCase )
 
 import Network.HTTP.Types
   ( methodGet
@@ -48,6 +46,7 @@ import Prometheus
   , unsafeRegister
   , counter
   , incCounter
+  , Counter
   )
 
 import PaymentServer.Metrics
@@ -73,12 +72,13 @@ readMetrics = request $ setPath defaultRequest { requestMethod = methodGet } "/m
 -- Register a counter at the top-level because the registry is global and this
 -- lets us avoid thinking about collisions or unregistration.  unsafeRegister
 -- is (only) safe for defining a top-level symbol.
+aCounter :: Counter
 aCounter = unsafeRegister $ counter (Info "a_counter" "A test counter.")
 
+-- | A ``GET /metrics`` request receives a text/plain OK response containing
+-- current Prometheus-formatted metrics information.
 metricsTests :: TestTree
 metricsTests =
-  -- | A ``GET /metrics`` request receives a text/plain OK response containing
-  -- current Prometheus-formatted metrics information.
   testCase "plaintext metrics response" $
   let
     app :: Application