From ee8e75231cd9d3d4aa3ffbbfa0e3b8511712e1ee Mon Sep 17 00:00:00 2001 From: William Carroll Date: Tue, 4 Aug 2020 09:19:48 +0100 Subject: Set -Wall and fix warnings I think setting -Wall is a sensible default and @dmjio confirmed this. After putting this in my project's .ghci file, a few dozen warnings emerged. This commit changes the code that causes the warnings. --- src/.ghci | 2 +- src/App.hs | 18 +++++++++--------- src/Auth.hs | 8 +------- src/Email.hs | 2 +- src/Sessions.hs | 2 +- src/Types.hs | 50 ++++++++++++++++++++++++-------------------------- src/Utils.hs | 1 + 7 files changed, 38 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/.ghci b/src/.ghci index f189fd0be2e6..efc88e630ccb 100644 --- a/src/.ghci +++ b/src/.ghci @@ -1,2 +1,2 @@ :set prompt "> " -:set -Wincomplete-patterns +:set -Wall diff --git a/src/App.hs b/src/App.hs index e56e7c1875f5..6a7de73a822f 100644 --- a/src/App.hs +++ b/src/App.hs @@ -11,7 +11,6 @@ import Control.Monad.IO.Class (liftIO) import Data.String.Conversions (cs) import Data.Text (Text) import Servant -import Servant.Server.Internal.ServerError import API import Utils import Web.Cookie @@ -20,10 +19,7 @@ import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Middleware.Cors as Cors import qualified System.Random as Random import qualified Email as Email -import qualified Crypto.KDF.BCrypt as BC -import qualified Data.Text.Encoding as TE import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID import qualified Types as T import qualified Accounts as Accounts import qualified Auth as Auth @@ -48,7 +44,7 @@ sendVerifyEmail :: T.Config -> T.Email -> T.RegistrationSecret -> IO (Either Email.SendError Email.SendSuccess) -sendVerifyEmail T.Config{..} (T.Username username) email@(T.Email to) (T.RegistrationSecret secretUUID) = do +sendVerifyEmail T.Config{..} (T.Username username) email (T.RegistrationSecret secretUUID) = do Email.send mailgunAPIKey subject (cs body) email where subject = "Please confirm your account" @@ -115,11 +111,13 @@ server config@T.Config{..} = createAccount createAccountRequestPassword createAccountRequestRole createAccountRequestEmail - liftIO $ sendVerifyEmail config + res <- liftIO $ sendVerifyEmail config createAccountRequestUsername createAccountRequestEmail secretUUID - pure NoContent + case res of + Left _ -> undefined + Right _ -> pure NoContent verifyAccount :: Text -> T.RegistrationSecret -> Handler NoContent verifyAccount username secretUUID = do @@ -239,8 +237,10 @@ server config@T.Config{..} = createAccount secretUUID inviteUserRequestEmail inviteUserRequestRole - liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID - pure NoContent + res <- liftIO $ sendInviteEmail config inviteUserRequestEmail secretUUID + case res of + Left _ -> undefined + Right _ -> pure NoContent acceptInvitation :: T.AcceptInvitationRequest -> Handler NoContent acceptInvitation T.AcceptInvitationRequest{..} = do diff --git a/src/Auth.hs b/src/Auth.hs index 4962ce50abef..f1bff23257e0 100644 --- a/src/Auth.hs +++ b/src/Auth.hs @@ -4,19 +4,13 @@ module Auth where -------------------------------------------------------------------------------- import Control.Monad.IO.Class (liftIO) -import Data.String.Conversions (cs) -import Database.SQLite.Simple -import Utils import Web.Cookie import Servant -import Servant.Server.Internal.ServerError import qualified Data.UUID as UUID -import qualified Web.Cookie as WC import qualified Sessions as Sessions import qualified Accounts as Accounts import qualified Types as T -import qualified Data.ByteString.Lazy as LBS -------------------------------------------------------------------------------- -- | Return the UUID from a Session cookie. @@ -28,7 +22,7 @@ uuidFromCookie (T.SessionCookie cookies) = do -- | Attempt to return the account associated with `cookie`. accountFromCookie :: FilePath -> T.SessionCookie -> IO (Maybe T.Account) -accountFromCookie dbFile cookie = withConnection dbFile $ \conn -> do +accountFromCookie dbFile cookie = case uuidFromCookie cookie of Nothing -> pure Nothing Just uuid -> do diff --git a/src/Email.hs b/src/Email.hs index 439b15d0ed4b..2dac0973ba6d 100644 --- a/src/Email.hs +++ b/src/Email.hs @@ -29,7 +29,7 @@ send apiKey subject body (T.Email to) = do res <- MG.sendEmail ctx x case res of Left e -> pure $ Left (ResponseError e) - Right x -> pure $ Right (SendSuccess x) + Right y -> pure $ Right (SendSuccess y) where ctx = MG.HailgunContext { MG.hailgunDomain = "sandboxda5038873f924b50af2f82a0f05cffdf.mailgun.org" , MG.hailgunApiKey = cs apiKey diff --git a/src/Sessions.hs b/src/Sessions.hs index f5b2f6f41000..713059a38383 100644 --- a/src/Sessions.hs +++ b/src/Sessions.hs @@ -58,7 +58,7 @@ delete dbFile uuid = withConnection dbFile $ \conn -> -- | Find or create a session in the Sessions table. If a session exists, -- refresh the token's validity. findOrCreate :: FilePath -> T.Account -> IO T.SessionUUID -findOrCreate dbFile account = withConnection dbFile $ \conn -> +findOrCreate dbFile account = let username = T.accountUsername account in do mSession <- find dbFile username case mSession of diff --git a/src/Types.hs b/src/Types.hs index 235e8a6d06df..00fa09ccc140 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -10,7 +10,6 @@ import Data.Aeson import Utils import Data.Text import Data.Typeable -import Data.String.Conversions (cs) import Database.SQLite.Simple import Database.SQLite.Simple.Ok import Database.SQLite.Simple.FromField @@ -22,7 +21,6 @@ import System.Envy (FromEnv, fromEnv, env) import Crypto.Random.Types (MonadRandom) import qualified Data.Time.Calendar as Calendar -import qualified Data.Time.Format as TF import qualified Crypto.KDF.BCrypt as BC import qualified Data.Time.Clock as Clock import qualified Data.ByteString.Char8 as B @@ -50,10 +48,10 @@ instance FromEnv Config where -- TODO(wpcarro): Properly handle NULL for columns like profilePicture. forNewtype :: (Typeable b) => (Text -> b) -> FieldParser b -forNewtype wrapper field = - case fieldData field of +forNewtype wrapper y = + case fieldData y of (SQLText x) -> Ok (wrapper x) - x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) newtype Username = Username Text deriving (Eq, Show, Generic) @@ -74,10 +72,10 @@ instance ToField HashedPassword where toField (HashedPassword x) = SQLText (TE.decodeUtf8 x) instance FromField HashedPassword where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> x |> TE.encodeUtf8 |> HashedPassword |> Ok - x -> returnError ConversionFailed field ("We expected SQLText, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected SQLText, but we received: " ++ show x) newtype ClearTextPassword = ClearTextPassword Text deriving (Eq, Show, Generic) @@ -125,12 +123,12 @@ instance ToField Role where toField Admin = SQLText "admin" instance FromField Role where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText "user") -> Ok RegularUser (SQLText "manager") -> Ok Manager (SQLText "admin") -> Ok Admin - x -> returnError ConversionFailed field ("We expected user, manager, admin, but we received: " ++ show x) + x -> returnError ConversionFailed y ("We expected user, manager, admin, but we received: " ++ show x) -- TODO(wpcarro): Prefer Data.ByteString instead of Text newtype ProfilePicture = ProfilePicture Text @@ -356,13 +354,13 @@ newtype SessionUUID = SessionUUID UUID.UUID deriving (Eq, Show, Generic) instance FromField SessionUUID where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field ("Could not convert to UUID: " ++ show x) - Just x -> Ok $ SessionUUID x - _ -> returnError ConversionFailed field "Expected SQLText for SessionUUID, but we received" + Nothing -> returnError ConversionFailed y ("Could not convert to UUID: " ++ show x) + Just uuid -> Ok $ SessionUUID uuid + _ -> returnError ConversionFailed y "Expected SQLText for SessionUUID, but we received" instance ToField SessionUUID where toField (SessionUUID uuid) = @@ -410,13 +408,13 @@ instance FromHttpApiData RegistrationSecret where Just uuid -> Right (RegistrationSecret uuid) instance FromField RegistrationSecret where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x) - Just x -> Ok $ RegistrationSecret x - _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just uuid -> Ok $ RegistrationSecret uuid + _ -> returnError ConversionFailed y "Field data is not SQLText, which is what we expect" instance ToField RegistrationSecret where toField (RegistrationSecret secretUUID) = @@ -498,13 +496,13 @@ instance ToField InvitationSecret where secretUUID |> UUID.toText |> SQLText instance FromField InvitationSecret where - fromField field = - case fieldData field of + fromField y = + case fieldData y of (SQLText x) -> case UUID.fromText x of - Nothing -> returnError ConversionFailed field ("Could not convert text to UUID: " ++ show x) - Just x -> Ok $ InvitationSecret x - _ -> returnError ConversionFailed field "Field data is not SQLText, which is what we expect" + Nothing -> returnError ConversionFailed y ("Could not convert text to UUID: " ++ show x) + Just z -> Ok $ InvitationSecret z + _ -> returnError ConversionFailed y "Field data is not SQLText, which is what we expect" data Invitation = Invitation { invitationEmail :: Email diff --git a/src/Utils.hs b/src/Utils.hs index 78ee93ec95de..48c33af0796d 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -5,4 +5,5 @@ import Data.Function ((&)) -------------------------------------------------------------------------------- -- | Prefer this operator to the ampersand for stylistic reasons. +(|>) :: a -> (a -> b) -> b (|>) = (&) -- cgit 1.4.1