From b0ab8985ed0dfc330a6add1ac782748af1d17397 Mon Sep 17 00:00:00 2001 From: Konstantinos Sideris Date: Tue, 9 Feb 2021 17:49:52 +0200 Subject: [PATCH] Clean up imports with relude --- app/Main.hs | 8 ++---- cabal.project | 5 +++- default.nix | 26 ++++++++--------- hakatime.cabal | 20 ++++++------- src/Haka/App.hs | 7 +---- src/Haka/Authentication.hs | 8 ++---- src/Haka/Badges.hs | 32 ++++++++------------- src/Haka/Cli.hs | 18 ++++++------ src/Haka/DatabaseOperations.hs | 23 +++++++-------- src/Haka/Db/Sessions.hs | 13 +++------ src/Haka/Db/Statements.hs | 52 ++++++++++++++++------------------ src/Haka/Errors.hs | 6 ++-- src/Haka/Heartbeats.hs | 38 ++++++++++++------------- src/Haka/Import.hs | 16 ++++------- src/Haka/Logger.hs | 11 ++----- src/Haka/Middleware.hs | 7 ++--- src/Haka/PasswordUtils.hs | 17 +++++------ src/Haka/Projects.hs | 23 ++++++--------- src/Haka/Stats.hs | 23 ++++++--------- src/Haka/Types.hs | 15 +++------- src/Haka/Users.hs | 7 +---- src/Haka/Utils.hs | 27 +++++++----------- tools/Main.hs | 6 ++-- 23 files changed, 162 insertions(+), 246 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 494871d..f990948 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -5,10 +5,6 @@ where import Control.Concurrent (forkIO, threadDelay) import Control.Exception.Safe (catchAny, try) -import Control.Monad (forever, when) -import Control.Monad.Trans.Except (ExceptT (..)) -import Data.Maybe (fromMaybe) -import Data.Text (pack) import qualified GHC.IO.Encoding import qualified Haka.Api as Api import Haka.App @@ -63,7 +59,7 @@ initApp settings unApp = do logenv <- Log.setupLogEnv (hakaRunEnv settings) - (fromMaybe InfoS (textToSeverity $ pack $ hakaLogLevel settings)) + (fromMaybe InfoS (textToSeverity $ toText $ hakaLogLevel settings)) let logState' = LogState { lsNamespace = Namespace {unNamespace = ["server"]}, @@ -83,7 +79,7 @@ initApp settings unApp = do runAppT appCtx Import.handleImportRequest `catchAny` ( \e -> do runKatipT logenv $ Log.logMs ErrorS "Failed to execute import request" - runKatipT logenv $ Log.logMs ErrorS (pack $ show e) + runKatipT logenv $ Log.logMs ErrorS (show e) threadDelay 1000000 ) diff --git a/cabal.project b/cabal.project index 77b0b42..4b8a9cd 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,8 @@ -index-state: 2020-09-26T11:49:41Z +index-state: 2021-01-25T10:18:41Z packages: *.cabal +package * + ghc-options: -fwrite-ide-info + package hakatime optimization: 2 diff --git a/default.nix b/default.nix index abdd10b..aae8ce8 100644 --- a/default.nix +++ b/default.nix @@ -2,12 +2,12 @@ , bytestring, case-insensitive, containers, contravariant-extras , cookie, cryptonite, fakedata, file-embed, hasql, hasql-pool , hasql-queue, hasql-transaction, http-client, http-client-tls -, http-media, http-types, katip, mr-env, mtl, optparse-applicative +, http-media, http-types, katip, mr-env, optparse-applicative , polysemy, polysemy-plugin, postgresql-binary, random -, raw-strings-qq, req, safe, safe-exceptions, servant +, raw-strings-qq, relude, req, safe, safe-exceptions, servant , servant-client, servant-server, stdenv, system-filepath, text -, time, transformers, unix, unliftio-core, uuid, uuid-types, wai -, wai-cors, wai-extra, wai-logger, warp +, time, unix, unliftio-core, uuid, uuid-types, wai, wai-cors +, wai-extra, wai-logger, warp }: mkDerivation { pname = "hakatime"; @@ -19,18 +19,18 @@ mkDerivation { aeson base base64-bytestring bits blaze-builder bytestring case-insensitive containers contravariant-extras cookie cryptonite file-embed hasql hasql-pool hasql-queue hasql-transaction - http-client http-client-tls http-media http-types katip mr-env mtl + http-client http-client-tls http-media http-types katip mr-env optparse-applicative polysemy polysemy-plugin postgresql-binary - raw-strings-qq req safe safe-exceptions servant servant-server - system-filepath text time transformers unix unliftio-core uuid - uuid-types wai + raw-strings-qq relude req safe safe-exceptions servant + servant-server system-filepath text time unix unliftio-core uuid + uuid-types wai wai-extra ]; executableHaskellDepends = [ - aeson base base64-bytestring bytestring fakedata hasql hasql-pool - hasql-queue http-client http-client-tls katip mr-env mtl - optparse-applicative polysemy polysemy-plugin random - safe-exceptions servant servant-client servant-server text time - transformers unix wai wai-cors wai-extra wai-logger warp + aeson base base64-bytestring fakedata hasql hasql-pool hasql-queue + http-client http-client-tls katip mr-env optparse-applicative + polysemy polysemy-plugin random relude safe-exceptions servant + servant-client servant-server time unix wai wai-cors wai-extra + wai-logger warp ]; testHaskellDepends = [ base ]; doHaddock = false; diff --git a/hakatime.cabal b/hakatime.cabal index dacb467..c9cef66 100644 --- a/hakatime.cabal +++ b/hakatime.cabal @@ -18,11 +18,12 @@ source-repository head executable haka-data hs-source-dirs: tools + mixins: base hiding (Prelude) + , relude (Relude as Prelude) main-is: Main.hs build-depends: base >= 4.9 && < 4.14 , aeson >= 1.4 , base64-bytestring - , bytestring , fakedata , polysemy == 1.3.* , polysemy-plugin == 0.2.* @@ -32,9 +33,9 @@ executable haka-data , optparse-applicative >= 0.15 , servant >= 0.17 , servant-client >= 0.17 - , text , time , libhaka + , relude >= 0.6.0.0 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -48,6 +49,8 @@ executable haka-data library libhaka hs-source-dirs: src + mixins: base hiding (Prelude) + , relude (Relude as Prelude, Relude.Unsafe) exposed-modules: Haka.Api , Haka.Cli , Haka.App @@ -96,7 +99,6 @@ library libhaka , mr-env == 0.1.* , req , unix - , mtl == 2.2.2 , optparse-applicative >= 0.15 , polysemy == 1.3.* , polysemy-plugin == 0.2.* @@ -109,14 +111,13 @@ library libhaka , system-filepath , text , time - , transformers - -- https://github.com/Soostone/katip/issues/117 - , unliftio-core >= 0.1 && < 0.2 + , unliftio-core , uuid , wai == 3.2.* , wai-extra , http-types , blaze-builder + , relude >= 0.6.0.0 ghc-options: -Wall -Wcompat @@ -151,10 +152,11 @@ library libhaka executable hakatime hs-source-dirs: app + mixins: base hiding (Prelude) + , relude (Relude as Prelude) main-is: Main.hs build-depends: base >= 4.9 && < 4.14 - , bytestring , hasql == 1.4.* , hasql-pool == 0.5.* , hasql-queue == 1.2.* @@ -162,19 +164,17 @@ executable hakatime , libhaka , mr-env == 0.1.* , unix - , mtl == 2.2.2 , safe-exceptions - , text , optparse-applicative >= 0.15 , polysemy == 1.3.* , polysemy-plugin == 0.2.* , servant-server == 0.17.* - , transformers , wai == 3.2.* , wai-cors , wai-extra , wai-logger == 2.3.* , warp == 3.3.* + , relude >= 0.6.0.0 ghc-options: -Wall -threaded diff --git a/src/Haka/App.hs b/src/Haka/App.hs index 3b906e4..f27361c 100644 --- a/src/Haka/App.hs +++ b/src/Haka/App.hs @@ -16,11 +16,6 @@ module Haka.App where import Control.Exception.Safe (MonadThrow, throw) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader, asks, local) -import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) -import qualified Data.ByteString as Bs -import Data.Int (Int64) import qualified Haka.Logger as Log import qualified Hasql.Pool as HqPool import Katip as K @@ -136,7 +131,7 @@ data ServerSettings = ServerSettings -- we'll have to adjust the Set-Cookie path. hakaApiPrefix :: String, -- | The external URL to be used for the badge generation. - hakaBadgeUrl :: Bs.ByteString, + hakaBadgeUrl :: ByteString, -- | Where to look for dashboard's static files. hakaDashboardPath :: FilePath, -- | Whether the registration is enabled. diff --git a/src/Haka/Authentication.hs b/src/Haka/Authentication.hs index 009472c..8b09863 100644 --- a/src/Haka/Authentication.hs +++ b/src/Haka/Authentication.hs @@ -10,15 +10,10 @@ module Haka.Authentication where import Control.Exception.Safe (throw) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString.Char8 as Bs -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import Data.Time (addUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) -import GHC.Generics import Haka.App (AppCtx (..), AppM, RegistrationStatus (..), ServerSettings (..)) import qualified Haka.DatabaseOperations as DbOps import qualified Haka.Errors as Err @@ -32,6 +27,7 @@ import Katip import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) +import qualified Relude.Unsafe as Unsafe import Servant import Web.Cookie @@ -144,7 +140,7 @@ mkRefreshTokenCookie tknData apiPrefix = where removeSlash p = Bs.pack $ case not $ null p of - True -> if last p == '/' then init p else p + True -> if Unsafe.last p == '/' then Unsafe.init p else p False -> p mkLoginResponse :: TokenData -> UTCTime -> LoginResponse diff --git a/src/Haka/Badges.hs b/src/Haka/Badges.hs index 2aaf8e9..ec5d28e 100644 --- a/src/Haka/Badges.hs +++ b/src/Haka/Badges.hs @@ -7,18 +7,9 @@ module Haka.Badges where import Control.Exception.Safe (throw) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) import Data.Aeson (FromJSON, ToJSON) import qualified Data.ByteString as Bs -import qualified Data.ByteString.Lazy as LBs -import Data.Int (Int64) -import Data.List (mapAccumR) -import Data.Maybe (fromMaybe) -import Data.Text (Text, unpack) -import Data.Text.Encoding (decodeUtf8) import qualified Data.UUID.Types as UUID -import GHC.Generics import Haka.App (AppCtx (..), AppM, ServerSettings (..)) import qualified Haka.DatabaseOperations as DbOps import qualified Haka.Errors as Err @@ -29,6 +20,7 @@ import Network.HTTP.Media ((//)) import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) +import qualified Relude.Unsafe as Unsafe import Servant import Text.Printf (printf) @@ -39,7 +31,7 @@ instance Accept SVG where contentType _ = "image" // "svg+xml" instance MimeRender SVG Bs.ByteString where - mimeRender _ = LBs.fromStrict + mimeRender _ = fromStrict type API = GetBadgeLink :<|> GetBadgeSvg @@ -124,30 +116,30 @@ badgeSvgHandler badgeId daysParam = do ( hakaShieldsIOUrl ss <> "/static/v1?" <> "label=" - <> unpack (badgeProject badgeRow) - <> "&message=" - <> compoundDuration activityTime + <> toString (badgeProject badgeRow) + <> ("&message=" :: String) + <> toString (compoundDuration activityTime) <> "&color=blue" ) response <- liftIO $ httpLbs request manager - return $ LBs.toStrict $ responseBody response + return $ toStrict $ responseBody response reduceBy :: Integral a => a -> [a] -> [a] n `reduceBy` xs = n' : ys where (n', ys) = mapAccumR quotRem n xs -durLabs :: [(Int64, String)] -durLabs = [(undefined, "wk"), (7, "day"), (24, "hrs"), (60, "min"), (60, "sec")] +durLabs :: [(Int64, Text)] +durLabs = [(0, "wk"), (7, "day"), (24, "hrs"), (60, "min"), (60, "sec")] -computeDurations :: Int64 -> [(Int64, String)] +computeDurations :: Int64 -> [(Int64, Text)] computeDurations t = - let ds = t `reduceBy` map fst (tail durLabs) + let ds = t `reduceBy` map fst (Unsafe.tail durLabs) in filter ((/= 0) . fst) $ zip ds (map snd durLabs) -compoundDuration :: Maybe Int64 -> String +compoundDuration :: Maybe Int64 -> Text compoundDuration Nothing = "no data" compoundDuration (Just v) = let durations = computeDurations v in if length durations > 0 - then unwords $ map (uncurry $ printf "%d %s") $ init durations + then unwords $ map (toText . \(n, s) -> printf "%d %s" n s :: String) $ Unsafe.init durations else "no data" diff --git a/src/Haka/Cli.hs b/src/Haka/Cli.hs index e7ec8df..f4cbb99 100644 --- a/src/Haka/Cli.hs +++ b/src/Haka/Cli.hs @@ -7,7 +7,6 @@ module Haka.Cli where import Data.Bits.Extras (w16) -import Data.Text (Text, unpack) import Data.Version (showVersion) import qualified Haka.PasswordUtils as PasswordUtils import qualified Haka.Utils as Utils @@ -16,7 +15,6 @@ import qualified Hasql.Pool as HasqlPool import qualified Options.Applicative as Opt import Paths_hakatime (version) import System.Environment.MrEnv (envAsInt) -import System.Exit (die) import System.Posix.Env.ByteString (getEnvDefault) getDbSettings :: IO HasqlConn.Settings @@ -92,22 +90,22 @@ handleCommand :: ServerCommand -> IO () -> IO () handleCommand Run action = action handleCommand (CreateToken ops) _ = do dbSettings <- getDbSettings - pass <- Utils.passwordInput "Password: " + passwd <- Utils.passwordInput "Password: " pool <- HasqlPool.acquire (10, 1, dbSettings) - token <- PasswordUtils.createToken pool username pass + token <- PasswordUtils.createToken pool username passwd case token of - Left err -> die $ unpack err + Left err -> die $ toString err Right val -> putStrLn $ "Please save the token. You won't be able to retrieve it again.\n" - <> unpack val + <> toString val where username = tUsername ops handleCommand (CreateUser ops) _ = do dbSettings <- getDbSettings - pass <- Utils.passwordInput "Set a password: " + passwd <- Utils.passwordInput "Set a password: " pool <- HasqlPool.acquire (10, 1, dbSettings) - hashUser <- PasswordUtils.mkUser username pass + hashUser <- PasswordUtils.mkUser username passwd case hashUser of Left err -> die (show err) Right user -> do @@ -116,10 +114,10 @@ handleCommand (CreateUser ops) _ = do handleError ( \_ -> do putStrLn $ "User " <> show username <> " created." - putStrLn $ "Run \"hakatime create-token -u " <> unpack username <> "\" to generate a token." + putStrLn $ "Run \"hakatime create-token -u " <> toString username <> "\" to generate a token." ) res where username = cUsername ops handleError :: HasqlPool.UsageError -> IO () - handleError = die . unpack . Utils.toStrError + handleError = die . toString . Utils.toStrError diff --git a/src/Haka/DatabaseOperations.hs b/src/Haka/DatabaseOperations.hs index d2f7e01..feee974 100644 --- a/src/Haka/DatabaseOperations.hs +++ b/src/Haka/DatabaseOperations.hs @@ -27,10 +27,7 @@ module Haka.DatabaseOperations ) where -import Control.Monad.IO.Class (liftIO) import Data.Aeson as A -import Data.Int (Int64) -import Data.Text (Text, pack) import Data.Time.Clock (UTCTime) import qualified Haka.Db.Sessions as Sessions import Haka.Errors (DatabaseException (..)) @@ -120,8 +117,8 @@ interpretDatabaseIO = GetUserByRefreshToken pool token -> do res <- liftIO $ HqPool.use pool (Sessions.getUserByRefreshToken token) either (throw . SessionException) pure res - ValidateCredentials pool user pass -> do - res <- liftIO $ HqPool.use pool (Sessions.validateUser PUtils.validatePassword user pass) + ValidateCredentials pool user passwd -> do + res <- liftIO $ HqPool.use pool (Sessions.validateUser PUtils.validatePassword user passwd) either (throw . SessionException) ( \isValid -> if isValid then pure $ Just user else pure Nothing @@ -148,12 +145,12 @@ interpretDatabaseIO = CreateWebToken pool user expiry -> do tknData <- liftIO $ mkTokenData user res <- liftIO $ HqPool.use pool (Sessions.createAccessTokens expiry tknData) - either (throw . SessionException) (\_ -> pure tknData) res - RegisterUser pool user pass expiry -> do + whenLeft tknData res (throw . SessionException) + RegisterUser pool user passwd expiry -> do tknData <- liftIO $ mkTokenData user - hashUser <- liftIO $ PUtils.mkUser user pass + hashUser <- liftIO $ PUtils.mkUser user passwd case hashUser of - Left err -> throw $ RegistrationFailed (pack $ show err) + Left err -> throw $ RegistrationFailed (show err) Right hashUser' -> do u <- liftIO $ PUtils.createUser pool hashUser' case u of @@ -162,7 +159,7 @@ interpretDatabaseIO = if userCreated then do res <- liftIO $ HqPool.use pool (Sessions.createAccessTokens expiry tknData) - either (throw . SessionException) (\_ -> pure tknData) res + whenLeft tknData res (throw . SessionException) else throw $ UsernameExists "Username already exists" ListApiTokens pool user -> do res <- liftIO $ HqPool.use pool (Sessions.listApiTokens user) @@ -305,8 +302,8 @@ createAuthTokens :: HqPool.Pool -> Int64 -> Sem r TokenData -createAuthTokens user pass pool expiry = do - res <- validateCredentials pool user pass +createAuthTokens user passwd pool expiry = do + res <- validateCredentials pool user passwd case res of Nothing -> throw InvalidCredentials Just u -> createWebToken pool u expiry @@ -343,7 +340,7 @@ clearTokens token (Just refreshToken) pool = do case res of 0 -> throw InvalidCredentials 1 -> throw InvalidCredentials - 2 -> pure () + 2 -> pass _ -> throw (OperationException "failed to delete all the tokens while logout") getApiTokens :: diff --git a/src/Haka/Db/Sessions.hs b/src/Haka/Db/Sessions.hs index 115f49c..fc7ae8c 100644 --- a/src/Haka/Db/Sessions.hs +++ b/src/Haka/Db/Sessions.hs @@ -22,13 +22,8 @@ module Haka.Db.Sessions ) where -import Control.Monad.IO.Class (liftIO) import qualified Crypto.Error as CErr import Data.Aeson as A -import Data.Int (Int64) -import Data.List (nub) -import Data.Maybe (mapMaybe) -import Data.Text (Text) import Data.Time.Clock (UTCTime, getCurrentTime) import qualified Haka.Db.Statements as Statements import Haka.Types @@ -67,7 +62,7 @@ getUserByRefreshToken token = do deleteToken :: ApiToken -> Session () deleteToken (ApiToken token) = do _ <- statement token Statements.deleteAuthToken - pure () + pass deleteTokens :: ApiToken -> Text -> Session Int64 deleteTokens (ApiToken token) refreshToken = do @@ -92,7 +87,7 @@ saveHeartbeats payloadData = do mapM (`statement` Statements.insertHeartBeat) payloadData where uniqueProjects = - nub $ + ordNub $ mapMaybe ( \x -> case (sender x, project x) of @@ -138,12 +133,12 @@ validateUser :: Text -> Text -> Session Bool -validateUser validate name pass = do +validateUser validate name passwd = do res <- statement name Statements.getUserByName case res of Nothing -> pure False Just savedUser -> - case validate savedUser name pass of + case validate savedUser name passwd of Left e -> do liftIO $ putStrLn $ diff --git a/src/Haka/Db/Statements.hs b/src/Haka/Db/Statements.hs index 6fe1a55..06e6ff0 100644 --- a/src/Haka/Db/Statements.hs +++ b/src/Haka/Db/Statements.hs @@ -30,11 +30,7 @@ where import Contravariant.Extras.Contrazip (contrazip3, contrazip4, contrazip5) import Data.Aeson as A -import qualified Data.ByteString as Bs import Data.FileEmbed -import Data.Functor.Contravariant ((>$<)) -import Data.Int (Int64) -import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Haka.Types @@ -57,7 +53,7 @@ import Text.RawString.QQ (r) updateTokenUsage :: Statement Text () updateTokenUsage = Statement query params D.noResult True where - query :: Bs.ByteString + query :: ByteString query = [r| UPDATE auth_tokens @@ -71,7 +67,7 @@ updateTokenUsage = Statement query params D.noResult True listApiTokens :: Statement Text [StoredApiToken] listApiTokens = Statement query params result True where - query :: Bs.ByteString + query :: ByteString query = [r| select @@ -100,7 +96,7 @@ createAPIToken = Statement query params D.noResult True where params :: E.Params (Text, Text) params = (fst >$< E.param (E.nonNullable E.text)) <> (snd >$< E.param (E.nonNullable E.text)) - query :: Bs.ByteString + query :: ByteString query = [r| INSERT INTO auth_tokens(owner, token) values($1, $2); |] createAccessTokens :: Int64 -> Statement TokenData () @@ -112,7 +108,7 @@ createAccessTokens refreshTokenExpiryHours = Statement query params D.noResult T <> (tknToken >$< E.param (E.nonNullable E.text)) <> (tknRefreshToken >$< E.param (E.nonNullable E.text)) <> (const refreshTokenExpiryHours >$< E.param (E.nonNullable E.int8)) - query :: Bs.ByteString + query :: ByteString query = [r| WITH x AS ( @@ -137,7 +133,7 @@ deleteExpiredTokens = Statement query params D.noResult True (tknOwner >$< E.param (E.nonNullable E.text)) <> (tknToken >$< E.param (E.nonNullable E.text)) <> (tknRefreshToken >$< E.param (E.nonNullable E.text)) - query :: Bs.ByteString + query :: ByteString query = [r| WITH x AS ( @@ -152,7 +148,7 @@ deleteRefreshToken = Statement query params D.rowsAffected True where params :: E.Params Text params = E.param (E.nonNullable E.text) - query :: Bs.ByteString + query :: ByteString query = [r| DELETE FROM refresh_tokens WHERE refresh_token = $1; |] deleteAuthToken :: Statement Text Int64 @@ -160,7 +156,7 @@ deleteAuthToken = Statement query params D.rowsAffected True where params :: E.Params Text params = E.param (E.nonNullable E.text) - query :: Bs.ByteString + query :: ByteString query = [r| DELETE FROM auth_tokens WHERE token = $1; |] doubleToUTCTime :: Real a => a -> UTCTime @@ -176,7 +172,7 @@ insertToken = D.noResult True where - query :: Bs.ByteString + query :: ByteString query = [r| INSERT INTO auth_tokens @@ -190,7 +186,7 @@ insertToken = getUserByName :: Statement Text (Maybe RegisteredUser) getUserByName = Statement query (E.param (E.nonNullable E.text)) userDecoder True where - query :: Bs.ByteString + query :: ByteString query = [r| SELECT * FROM users WHERE username = $1;|] userDecoder :: D.Result (Maybe RegisteredUser) userDecoder = D.rowMaybe user @@ -211,7 +207,7 @@ getTotalActivityTime = Statement query params result True (E.param (E.nonNullable E.text)) (E.param (E.nonNullable E.int8)) (E.param (E.nonNullable E.text)) - query :: Bs.ByteString + query :: ByteString query = $(embedFile "sql/get_total_project_time.sql") result :: D.Result (Maybe Int64) result = D.rowMaybe $ (D.column . D.nonNullable) D.int8 @@ -226,7 +222,7 @@ insertUser = Statement query params D.noResult True ) <> (hashedPassword >$< E.param (E.nonNullable E.bytea)) <> (saltUsed >$< E.param (E.nonNullable E.bytea)) - query :: Bs.ByteString + query :: ByteString query = [r| INSERT INTO users @@ -241,7 +237,7 @@ insertUser = Statement query params D.noResult True isUserAvailable :: Statement Text (Maybe RegisteredUser) isUserAvailable = Statement query (E.param (E.nonNullable E.text)) userDecoder True where - query :: Bs.ByteString + query :: ByteString query = [r| SELECT * FROM users WHERE username = $1 |] userDecoder :: D.Result (Maybe RegisteredUser) @@ -266,7 +262,7 @@ getUserByToken = where -- NOTE: On auth tokens the expiry date might not be set. -- The tokens created by the CLI do not expire. - query :: Bs.ByteString + query :: ByteString query = [r| SELECT owner FROM auth_tokens @@ -287,7 +283,7 @@ getUserByRefreshToken = (D.rowMaybe ((D.column . D.nonNullable) D.text)) True where - query :: Bs.ByteString + query :: ByteString query = [r| SELECT owner FROM refresh_tokens @@ -301,7 +297,7 @@ insertProject = Statement query params D.noResult True where params :: E.Params (Text, Text) params = (fst >$< E.param (E.nonNullable E.text)) <> (snd >$< E.param (E.nonNullable E.text)) - query :: Bs.ByteString + query :: ByteString query = [r| INSERT INTO projects (owner, name) VALUES ( $1, $2 ) ON CONFLICT DO NOTHING; @@ -314,7 +310,7 @@ createBadgeLink = Statement query params result True params = (fst >$< E.param (E.nonNullable E.text)) <> (snd >$< E.param (E.nonNullable E.text)) result :: D.Result UUID result = D.singleRow (D.column (D.nonNullable D.uuid)) - query :: Bs.ByteString + query :: ByteString query = [r| INSERT INTO badges(username, project) values($1, $2) @@ -333,7 +329,7 @@ getBadgeLinkInfo = Statement query params result True ( BadgeRow <$> (D.column . D.nonNullable) D.text <*> (D.column . D.nonNullable) D.text ) - query :: Bs.ByteString + query :: ByteString query = [r| SELECT username, project FROM badges WHERE link_id = $1; |] insertHeartBeat :: Statement HeartbeatPayload Int64 @@ -341,7 +337,7 @@ insertHeartBeat = Statement query params result True where result :: D.Result Int64 result = D.singleRow (D.column (D.nonNullable D.int8)) - query :: Bs.ByteString + query :: ByteString query = $(embedFile "sql/insert_heartbeat.sql") params :: E.Params HeartbeatPayload params = @@ -357,7 +353,7 @@ insertHeartBeat = Statement query params result True <> ( dependencies >$< E.param ( E.nullable - ( E.array (E.dimension foldl (E.element (E.nonNullable E.text))) + ( E.array (E.dimension foldl' (E.element (E.nonNullable E.text))) ) ) ) @@ -379,7 +375,7 @@ insertHeartBeat = Statement query params result True getProjectStats :: Statement (Text, Text, UTCTime, UTCTime, Int64) [ProjectStatRow] getProjectStats = Statement query params result True where - query :: Bs.ByteString + query :: ByteString query = $(embedFile "sql/get_projects_stats.sql") params :: E.Params (Text, Text, UTCTime, UTCTime, Int64) params = @@ -406,7 +402,7 @@ getProjectStats = Statement query params result True getUserActivity :: Statement (Text, UTCTime, UTCTime, Int64) [StatRow] getUserActivity = Statement query params result True where - query :: Bs.ByteString + query :: ByteString query = $(embedFile "sql/get_user_activity.sql") params :: E.Params (Text, UTCTime, UTCTime, Int64) params = @@ -435,7 +431,7 @@ getUserActivity = Statement query params result True getTimeline :: Statement (Text, UTCTime, UTCTime, Int64) [TimelineRow] getTimeline = Statement query params result True where - query :: Bs.ByteString + query :: ByteString query = $(embedFile "sql/get_timeline.sql") params :: E.Params (Text, UTCTime, UTCTime, Int64) params = @@ -459,7 +455,7 @@ deleteFailedJobs = Statement query params D.rowsAffected True where params :: E.Params A.Value params = E.param (E.nonNullable E.json) - query :: Bs.ByteString + query :: ByteString query = [r| DELETE FROM payloads WHERE value::text = $1::text; |] getJobStatus :: Statement A.Value (Maybe Text) @@ -467,5 +463,5 @@ getJobStatus = Statement query params (D.rowMaybe ((D.column . D.nonNullable) D. where params :: E.Params A.Value params = E.param (E.nonNullable E.json) - query :: Bs.ByteString + query :: ByteString query = [r| SELECT state FROM payloads WHERE value::text = $1::text; |] diff --git a/src/Haka/Errors.hs b/src/Haka/Errors.hs index 7b7e26d..6be32f5 100644 --- a/src/Haka/Errors.hs +++ b/src/Haka/Errors.hs @@ -22,8 +22,6 @@ import Control.Exception.Safe (MonadThrow, throw) import Data.Aeson (FromJSON (..), ToJSON (..), encode, genericParseJSON, genericToJSON) import qualified Data.ByteString.Char8 as C import Data.CaseInsensitive (mk) -import Data.Text (Text, pack) -import GHC.Generics import Haka.AesonHelpers (noPrefixOptions, untagged) import Haka.Types (BulkHeartbeatData, HearbeatData) import qualified Hasql.Pool as HqPool @@ -136,7 +134,7 @@ toJSONError :: DatabaseException -> ServerError toJSONError UnknownApiToken = invalidTokenError toJSONError ExpiredToken = expiredToken toJSONError InvalidCredentials = invalidCredentials -toJSONError (SessionException e) = genericError (pack $ show e) +toJSONError (SessionException e) = genericError (show e :: Text) toJSONError (OperationException e) = genericError e toJSONError (UsernameExists _) = usernameExists toJSONError (RegistrationFailed _) = registerError @@ -144,5 +142,5 @@ toJSONError MissingRefreshTokenCookie = missingRefreshTokenCookie logError :: (KatipContext m, MonadThrow m) => DatabaseException -> m b logError e = do - $(logTM) ErrorS (logStr $ show e) + $(logTM) ErrorS (logStr (show e :: String)) throw $ toJSONError e diff --git a/src/Haka/Heartbeats.hs b/src/Haka/Heartbeats.hs index 6283b6b..9ce3416 100644 --- a/src/Haka/Heartbeats.hs +++ b/src/Haka/Heartbeats.hs @@ -10,14 +10,11 @@ module Haka.Heartbeats where import Control.Exception.Safe (throw) -import Control.Monad.Reader (asks) import Data.Aeson (ToJSON) -import Data.Int (Int64) -import qualified Data.Text as T +import Data.Text (toUpper) import Data.Time.Calendar (Day) import Filesystem.Path (splitExtension) import Filesystem.Path.CurrentOS (fromText) -import GHC.Generics import Haka.App (AppCtx (..), AppM) import qualified Haka.DatabaseOperations as DbOps import Haka.Errors (HeartbeatApiResponse (..)) @@ -28,12 +25,13 @@ import Katip import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) +import qualified Relude.Unsafe as Unsafe import Servant data User = User - { name :: T.Text, + { name :: Text, age :: Int, - email :: T.Text, + email :: Text, registration_date :: Day } deriving (Eq, Show, Generic) @@ -59,7 +57,7 @@ type SingleHeartbeat = :> "users" :> "current" :> "heartbeats" - :> Header "X-Machine-Name" T.Text + :> Header "X-Machine-Name" Text :> Header "Authorization" ApiToken :> ReqBody '[JSON] HeartbeatPayload :> Post '[JSON] HeartbeatApiResponse @@ -70,7 +68,7 @@ type MultipleHeartbeats = :> "users" :> "current" :> "heartbeats.bulk" - :> Header "X-Machine-Name" T.Text + :> Header "X-Machine-Name" Text :> Header "Authorization" ApiToken :> ReqBody '[JSON] [HeartbeatPayload] :> Post '[JSON] HeartbeatApiResponse @@ -78,24 +76,24 @@ type MultipleHeartbeats = type API = SingleHeartbeat :<|> MultipleHeartbeats server :: - ( Maybe T.Text -> + ( Maybe Text -> Maybe ApiToken -> HeartbeatPayload -> AppM HeartbeatApiResponse ) - :<|> ( Maybe T.Text -> + :<|> ( Maybe Text -> Maybe ApiToken -> [HeartbeatPayload] -> AppM HeartbeatApiResponse ) server = heartbeatHandler :<|> multiHeartbeatHandler -mkHeartbeatId :: T.Text -> HearbeatData +mkHeartbeatId :: Text -> HearbeatData mkHeartbeatId i = HearbeatData {heartbeatData = HeartbeatId {heartbeatId = i}} handleSingleDbResult :: [Int64] -> AppM HeartbeatApiResponse handleSingleDbResult ids = - pure $ SingleHeartbeatApiResponse $ mkHeartbeatId (T.pack $ show (head ids)) + pure $ SingleHeartbeatApiResponse $ mkHeartbeatId (show (Unsafe.head ids)) handleManyDbResults :: [Int64] -> AppM HeartbeatApiResponse handleManyDbResults ids = @@ -106,14 +104,14 @@ handleManyDbResults ids = mkResponseItem = map ( \x -> - [ ReturnData $ mkHeartbeatId (T.pack $ show x), + [ ReturnData $ mkHeartbeatId (show x), ReturnCode 201 ] ) heartbeatHandler :: -- | X-Machine-Name header field with the hostname. - Maybe T.Text -> + Maybe Text -> -- | Authorization header field with the Api token. Maybe ApiToken -> HeartbeatPayload -> @@ -127,14 +125,14 @@ heartbeatHandler machineId (Just token) heartbeat = do multiHeartbeatHandler :: -- | X-Machine-Name header field with the hostname. - Maybe T.Text -> + Maybe Text -> -- | Authorization header field with the Api token. Maybe ApiToken -> [HeartbeatPayload] -> AppM HeartbeatApiResponse multiHeartbeatHandler _ Nothing _ = throw Err.missingAuthError multiHeartbeatHandler machineId (Just token) heartbeats = do - $(logTM) InfoS (logStr ("received " <> show (length heartbeats) <> " heartbeats")) + $(logTM) InfoS ("received " <> showLS (length heartbeats) <> " heartbeats") p <- asks pool res <- storeHeartbeats p token machineId heartbeats mkResponse res @@ -153,14 +151,14 @@ addMissingLang hb@HeartbeatPayload {language = Nothing, ty = FileType} = let lang = convertToLang $ findExt (entity hb) in hb {language = lang} where - findExt :: T.Text -> Maybe T.Text + findExt :: Text -> Maybe Text findExt = snd . splitExtension . fromText - convertToLang :: Maybe T.Text -> Maybe T.Text + convertToLang :: Maybe Text -> Maybe Text convertToLang (Just ext) = case ext of "" -> Nothing "." -> Nothing - a -> Just $ T.toUpper a + a -> Just $ toUpper a convertToLang _ = Nothing addMissingLang hb = hb @@ -168,7 +166,7 @@ addMissingLang hb = hb storeHeartbeats :: Pool -> ApiToken -> - Maybe T.Text -> + Maybe Text -> [HeartbeatPayload] -> AppM (Either DbOps.DatabaseException [Int64]) storeHeartbeats p token machineId heartbeats = diff --git a/src/Haka/Import.hs b/src/Haka/Import.hs index 7553524..d7f332d 100644 --- a/src/Haka/Import.hs +++ b/src/Haka/Import.hs @@ -7,17 +7,10 @@ module Haka.Import ) where -import Control.Exception.Safe (Exception, Typeable, bracket, throw) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask, asks) +import Control.Exception.Safe (bracket, throw) import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as Bs -import Data.Foldable (traverse_) -import Data.Int (Int64) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime (..)) -import GHC.Generics import Haka.AesonHelpers (noPrefixOptions) import Haka.App (AppCtx (..), AppM, runAppT) import qualified Haka.Cli as Cli @@ -35,6 +28,7 @@ import qualified Network.HTTP.Req as R import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) +import qualified Relude.Unsafe as Unsafe import Servant data JobStatus @@ -186,7 +180,7 @@ convertForDb :: Text -> [UserAgentPayload] -> [ImportHeartbeatPayload] -> [Heart convertForDb user userAgents = map convertSchema where convertSchema payload = - let userAgentValue = uaValue $ head $ filter (\x -> uaId x == wUser_agent_id payload) userAgents + let userAgentValue = uaValue $ Unsafe.head $ filter (\x -> uaId x == wUser_agent_id payload) userAgents in HeartbeatPayload { branch = wBranch payload, category = wCategory payload, @@ -246,7 +240,7 @@ handleImportRequest = do if null items then throw $ MalformedPaylod "Received empty payload list" else do - case A.fromJSON (head items) :: A.Result QueueItem of + case A.fromJSON (Unsafe.head items) :: A.Result QueueItem of A.Success item -> runAppT ctx $ process item A.Error e -> throw $ MalformedPaylod e @@ -277,7 +271,7 @@ enqueueRequest payload = do case res of Left Nothing -> error "failed to acquire connection while enqueuing import request" - Left (Just e) -> error $ Bs.unpack e + Left (Just e) -> error $ decodeUtf8 e Right conn -> HasqlQueue.enqueue queueName conn E.json [payload] type ImportRequestHandler = Maybe ApiToken -> ImportRequestPayload -> AppM ImportRequestResponse diff --git a/src/Haka/Logger.hs b/src/Haka/Logger.hs index fbe769a..19cab05 100644 --- a/src/Haka/Logger.hs +++ b/src/Haka/Logger.hs @@ -12,18 +12,13 @@ module Haka.Logger ) where -import Data.Text (Text) -import qualified Data.Text as T import Data.Text.Internal.Builder -import qualified Data.Text.Lazy as LT import Katip import Katip.Core (locationToString) import Katip.Format.Time (formatAsIso8601) import Katip.Scribes.Handle import qualified Network.Wai as Wai import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev) -import System.IO -import Prelude hiding (unwords) data EnvType = Dev | Prod deriving (Show, Eq) @@ -70,10 +65,10 @@ pairFormat :: ItemFormatter a pairFormat withColor _ Item {..} = pair "ts" nowStr <> pair "level" (renderSeverity' _itemSeverity) - <> pair "host" (T.pack _itemHost) + <> pair "host" (toText _itemHost) <> pair "thread_id" (getThreadIdText _itemThread) - <> maybe mempty (pair "loc" . T.pack . locationToString) _itemLoc - <> pair "msg" (LT.toStrict $ toLazyText $ unLogStr _itemMessage) + <> maybe mempty (pair "loc" . toText . locationToString) _itemLoc + <> pair "msg" (toStrict $ toLazyText $ unLogStr _itemMessage) where nowStr = formatAsIso8601 _itemTime renderSeverity' severity = diff --git a/src/Haka/Middleware.hs b/src/Haka/Middleware.hs index 6645107..3d91b60 100644 --- a/src/Haka/Middleware.hs +++ b/src/Haka/Middleware.hs @@ -3,10 +3,7 @@ module Haka.Middleware (jsonResponse) where import Blaze.ByteString.Builder (toLazyByteString) import Blaze.ByteString.Builder.ByteString (fromByteString) import Data.Aeson -import Data.ByteString.Lazy (toStrict) -import Data.Text -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Encoding (decodeUtf8) +import Data.Text (isInfixOf) import Network.HTTP.Types import Network.Wai import Network.Wai.Internal @@ -24,7 +21,7 @@ responseModifier r | otherwise = r customErrorBody :: Response -> Text -> Text -customErrorBody (ResponseBuilder _ _ b) _ = TL.toStrict $ decodeUtf8 $ toLazyByteString b +customErrorBody (ResponseBuilder _ _ b) _ = toStrict $ decodeUtf8 $ toLazyByteString b customErrorBody (ResponseRaw _ res) e = customErrorBody res e customErrorBody _ e = e diff --git a/src/Haka/PasswordUtils.hs b/src/Haka/PasswordUtils.hs index 70996b7..fdef12d 100644 --- a/src/Haka/PasswordUtils.hs +++ b/src/Haka/PasswordUtils.hs @@ -9,9 +9,6 @@ where import qualified Crypto.Error as CErr import qualified Crypto.KDF.Argon2 as Argon2 import qualified Crypto.Random.Entropy as Entropy -import qualified Data.ByteString as Bs -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) import qualified Haka.Db.Sessions as Sessions import Haka.Types (RegisteredUser (..)) import Haka.Utils (randomToken, toBase64, toStrError) @@ -23,14 +20,14 @@ hashOutputLen = 64 hashSaltLen :: Int hashSaltLen = 64 -argonHash :: Bs.ByteString -> Text -> CErr.CryptoFailable Bs.ByteString +argonHash :: ByteString -> Text -> CErr.CryptoFailable ByteString argonHash salt password = - Argon2.hash Argon2.defaultOptions (encodeUtf8 password) salt hashOutputLen + Argon2.hash Argon2.defaultOptions (encodeUtf8 password :: ByteString) salt hashOutputLen mkUser :: Text -> Text -> IO (Either CErr.CryptoError RegisteredUser) -mkUser name pass = do +mkUser name passwd = do salt <- Entropy.getEntropy hashSaltLen - case argonHash salt pass of + case argonHash salt passwd of CErr.CryptoFailed e -> pure $ Left e CErr.CryptoPassed v -> pure $ @@ -58,8 +55,8 @@ createUser hpool user = HasqlPool.use hpool (Sessions.insertUser user) -- | Validate the user credentials and generate a token for it if successful. createToken :: HasqlPool.Pool -> Text -> Text -> IO (Either Text Text) -createToken hpool name pass = do - validationResult <- HasqlPool.use hpool (Sessions.validateUser validatePassword name pass) +createToken hpool name passwd = do + validationResult <- HasqlPool.use hpool (Sessions.validateUser validatePassword name passwd) either (pure . Left . toStrError) genToken validationResult where genToken :: Bool -> IO (Either Text Text) @@ -76,4 +73,4 @@ createToken hpool name pass = do -- TODO: Encrypt the token -- tokenResult <- HasqlPool.use hpool (Sessions.insertToken (toBase64 token) name) - either (pure . Left . toStrError) (\_ -> pure $ Right token) tokenResult + whenLeft (Right token) tokenResult (pure . Left . toStrError) diff --git a/src/Haka/Projects.hs b/src/Haka/Projects.hs index 011ef26..f01c005 100644 --- a/src/Haka/Projects.hs +++ b/src/Haka/Projects.hs @@ -8,28 +8,23 @@ module Haka.Projects where import Control.Exception.Safe (throw) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import Data.Int (Int64) import qualified Data.List as List import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) import Data.Time (addDays, diffDays) import Data.Time.Clock (UTCTime (..), getCurrentTime) -import GHC.Generics import Haka.AesonHelpers (noPrefixOptions) import Haka.App (AppCtx (..), AppM) import qualified Haka.DatabaseOperations as DbOps import Haka.Errors (missingAuthError) import qualified Haka.Errors as Err import Haka.Types (ApiToken (..), ProjectStatRow (..)) -import Haka.Utils (defaultLimit, sum') +import Haka.Utils (defaultLimit) import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) import PostgreSQL.Binary.Data (Scientific) +import qualified Relude.Unsafe as Unsafe import Servant data ResourceStats = ResourceStats @@ -142,7 +137,7 @@ toStatsPayload t0 t1 xs = { totalSeconds = allSecs, startDate = t0, endDate = t1, - dailyTotal = map (sum' . map prTotalSeconds) byDate, + dailyTotal = map (sum . map prTotalSeconds) byDate, languages = getSegment prLanguage, files = getSegment prEntity, weekDay = getSegment prWeekday, @@ -157,18 +152,18 @@ toStatsPayload t0 t1 xs = in map ( \name -> let (secs', pct', dailyPct') = - unzip3 $ map (\(_, m') -> Data.Maybe.fromMaybe (0, 0, 0) (Map.lookup name m')) all' + unzip3 $ map (\(_, m') -> fromMaybe (0, 0, 0) (Map.lookup name m')) all' in ResourceStats { pName = name, - pTotalSeconds = sum' secs', - pTotalPct = sum' pct', + pTotalSeconds = sum secs', + pTotalPct = sum pct', pTotalDaily = secs', pPctDaily = dailyPct' } ) uniqProjectNames allSecs :: Int64 - allSecs = sum' $ [prTotalSeconds x | x <- xs] + allSecs = sum $ [prTotalSeconds x | x <- xs] byDate :: [[ProjectStatRow]] byDate = fillMissing (genDates t0 t1) (List.groupBy (\a b -> prDay a == prDay b) xs) @@ -179,7 +174,7 @@ fillMissing times rows = go times rows ([] :: [[ProjectStatRow]]) go [] _ res = res go _ [] res = res go (t : ts) rows'@(r : rs) res = - if utctDay t == utctDay (prDay $ head r) + if utctDay t == utctDay (prDay $ Unsafe.head r) then go ts rs (res ++ [r]) else go ts rows' (res ++ [[]]) @@ -206,7 +201,7 @@ aggregateBy :: -- | Total seconds of activity per field for that day. Maybe (UTCTime, Map.Map Text CalcStatistics) -- aggregateBy _ [] = Nothing -aggregateBy f rows = Just (prDay $ head rows, go rows Map.empty) +aggregateBy f rows = Just (prDay $ Unsafe.head rows, go rows Map.empty) where go :: [ProjectStatRow] -> Map.Map Text CalcStatistics -> Map.Map Text CalcStatistics go [] m' = m' diff --git a/src/Haka/Stats.hs b/src/Haka/Stats.hs index fadc781..e333dc1 100644 --- a/src/Haka/Stats.hs +++ b/src/Haka/Stats.hs @@ -7,28 +7,23 @@ module Haka.Stats where import Control.Exception.Safe (throw) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (asks) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import Data.Int (Int64) import qualified Data.List as List import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Text (Text) import Data.Time (addDays, diffDays, diffUTCTime) import Data.Time.Clock (UTCTime (..), getCurrentTime) -import GHC.Generics import Haka.AesonHelpers (noPrefixOptions) import Haka.App (AppCtx (..), AppM) import qualified Haka.DatabaseOperations as DbOps import Haka.Errors (missingAuthError) import qualified Haka.Errors as Err import Haka.Types (ApiToken (..), StatRow (..), TimelineRow (..)) -import Haka.Utils (defaultLimit, sum') +import Haka.Utils (defaultLimit) import Polysemy (runM) import Polysemy.Error (runError) import Polysemy.IO (embedToMonadIO) import PostgreSQL.Binary.Data (Scientific) +import qualified Relude.Unsafe as Unsafe import Servant data ResourceStats = ResourceStats @@ -241,7 +236,7 @@ fillMissing times rows = go times rows ([] :: [[StatRow]]) go [] _ res = res go _ [] res = res go (t : ts) rows'@(r : rs) res = - if utctDay t == utctDay (rDay $ head r) + if utctDay t == utctDay (rDay $ Unsafe.head r) then go ts rs (res ++ [r]) else go ts rows' (res ++ [[]]) @@ -262,7 +257,7 @@ toStatsPayload t0 t1 xs = startDate = t0, endDate = t1, dailyAvg = dailyAvgSecs, - dailyTotal = map (sum' . map rTotalSeconds) byDate, + dailyTotal = map (sum . map rTotalSeconds) byDate, projects = getSegment rProject, editors = getSegment rEditor, languages = getSegment rLanguage, @@ -278,18 +273,18 @@ toStatsPayload t0 t1 xs = in map ( \name -> let (secs', pct', dailyPct') = - unzip3 $ map (\(_, m') -> Data.Maybe.fromMaybe (0, 0, 0) (Map.lookup name m')) all' + unzip3 $ map (\(_, m') -> fromMaybe (0, 0, 0) (Map.lookup name m')) all' in ResourceStats { pName = name, - pTotalSeconds = sum' secs', - pTotalPct = sum' pct', + pTotalSeconds = sum secs', + pTotalPct = sum pct', pTotalDaily = secs', pPctDaily = dailyPct' } ) uniqProjectNames allSecs :: Int64 - allSecs = sum' $ [rTotalSeconds x | x <- xs] + allSecs = sum $ [rTotalSeconds x | x <- xs] dailyAvgSecs :: Double dailyAvgSecs = fromIntegral allSecs / numOfDays byDate :: [[StatRow]] @@ -311,7 +306,7 @@ aggregateBy :: -- | Total seconds of activity per field for that day. Maybe (UTCTime, Map.Map Text CalcStatistics) -- aggregateBy _ [] = Nothing -aggregateBy f rows = Just (rDay $ head rows, go rows Map.empty) +aggregateBy f rows = Just (rDay $ Unsafe.head rows, go rows Map.empty) where go :: [StatRow] -> Map.Map Text CalcStatistics -> Map.Map Text CalcStatistics go [] m' = m' diff --git a/src/Haka/Types.hs b/src/Haka/Types.hs index dc5faec..e7a7d99 100644 --- a/src/Haka/Types.hs +++ b/src/Haka/Types.hs @@ -29,16 +29,9 @@ import Data.Aeson ) import qualified Data.Aeson as A import qualified Data.ByteString as Bs -import Data.Int (Int64) -import Data.Text (Text, strip) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text (strip) import Data.Time.Clock (UTCTime) -import GHC.Generics -import Haka.AesonHelpers - ( convertReservedWords, - noPrefixOptions, - untagged, - ) +import Haka.AesonHelpers (convertReservedWords, noPrefixOptions, untagged) import qualified Haka.Utils as Utils import PostgreSQL.Binary.Data (Scientific) import Servant @@ -67,8 +60,8 @@ data TokenData = TokenData data RegisteredUser = RegisteredUser { username :: Text, - hashedPassword :: Bs.ByteString, - saltUsed :: Bs.ByteString + hashedPassword :: ByteString, + saltUsed :: ByteString } deriving (Eq, Show) diff --git a/src/Haka/Users.hs b/src/Haka/Users.hs index 8dd10ed..f7ddd37 100644 --- a/src/Haka/Users.hs +++ b/src/Haka/Users.hs @@ -8,13 +8,8 @@ module Haka.Users where import Control.Exception.Safe (throw) -import Control.Monad (when) -import Control.Monad.Reader (asks) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) -import Data.Maybe (fromJust, isNothing) -import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8) -import GHC.Generics +import Data.Maybe (fromJust) import Haka.AesonHelpers (noPrefixOptions) import Haka.App (AppCtx (..), AppM) import qualified Haka.DatabaseOperations as DbOps diff --git a/src/Haka/Utils.hs b/src/Haka/Utils.hs index ef2fe35..169facc 100644 --- a/src/Haka/Utils.hs +++ b/src/Haka/Utils.hs @@ -13,17 +13,12 @@ module Haka.Utils rollingGroupBy, countDuration, fmtDate, - sum', ) where import Control.Exception (bracket_) -import qualified Data.ByteString as Bs import Data.ByteString.Base64 (encode) -import Data.Int (Int64) -import Data.List (foldl') -import Data.Text (Text, pack, splitOn) -import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text (splitOn) import Data.Time (addDays, diffDays) import Data.Time.Clock (UTCTime (..)) import Data.Time.Format (defaultTimeLocale, formatTime) @@ -31,13 +26,11 @@ import qualified Data.UUID as UUID import Data.UUID.V4 (nextRandom) import Hasql.Pool (UsageError (..)) import qualified Hasql.Session as S +import qualified Relude.Unsafe as Unsafe import Safe (headMay) -import System.IO (hFlush, hGetEcho, hSetEcho, stdin, stdout) +import System.IO (hFlush, hGetEcho, hSetEcho, putChar) import Web.Cookie -sum' :: (Num a, Foldable t) => t a -> a -sum' = foldl' (+) 0 - defaultLimit :: Int64 defaultLimit = 15 @@ -58,7 +51,7 @@ rollingGroupBy predicate xs = go predicate xs [] [] | pFn m y = go pFn ms [y, m] total | otherwise = go pFn ms [m] (curr : total) go pFn (m : ms) curr total - | pFn m (last curr) = go pFn ms (curr ++ [m]) total + | pFn m (Unsafe.last curr) = go pFn ms (curr ++ [m]) total | otherwise = go pFn ms [m] (curr : total) -- | Given a set of timestamps & a cut-off value determined the total number of minutes counted. @@ -67,12 +60,12 @@ rollingGroupBy predicate xs = go predicate xs [] [] -- >>> 12 countDuration :: [Int] -> Int -> Int countDuration points interval = - sum' $ map countDiff $ groupByDiff points + sum $ map countDiff $ groupByDiff points where groupByDiff = rollingGroupBy (\x y -> abs (y - x) <= interval) countDiff [] = 0 countDiff [_] = 0 - countDiff (x : xs) = abs (x - last xs) + countDiff (x : xs) = abs (x - Unsafe.last xs) data EditorInfo = EditorInfo { editor :: Maybe Text, @@ -112,9 +105,9 @@ passwordInput :: String -> IO Text passwordInput prompt = do putStr prompt hFlush stdout - pass <- withEcho False getLine + passwd <- withEcho False getLine putChar '\n' - return $ pack pass + return $ toText passwd where withEcho :: Bool -> IO a -> IO a withEcho echo action = do @@ -147,9 +140,9 @@ toStrError (S.ResultError (S.UnexpectedResult err)) ) ) = err -toStrError err = pack $ show err +toStrError err = toText (show err :: String) -getRefreshToken :: Bs.ByteString -> Maybe Text +getRefreshToken :: ByteString -> Maybe Text getRefreshToken cookies = let value = headMay $ map snd $ filter (\(k, _) -> k == "refresh_token") (parseCookies cookies) in case value of diff --git a/tools/Main.hs b/tools/Main.hs index 13934e6..dd4581f 100644 --- a/tools/Main.hs +++ b/tools/Main.hs @@ -1,8 +1,6 @@ -- -- CLI tool that generates fake activity hearbeats. -- -import Control.Monad (replicateM) -import Data.Text (Text, pack) import Data.Time (addUTCTime) import Data.Time.Clock.POSIX import Faker @@ -78,7 +76,7 @@ fakeFilename = do "resources" ] ext <- elements [".cpp", ".go", ".hs", ".json", ".js", ".ts", ".py", ".rb", ".yaml", ".rs"] - pure $ pack $ filename ++ ext + pure $ toText $ filename ++ ext generateTimeline :: IO [HeartbeatPayload] generateTimeline = do @@ -181,7 +179,7 @@ runClient = do mgr <- mkMgr parsedConf r <- runClientM - (sendHeartbeats (Just "laptop") (Just $ ApiToken (pack $ token parsedConf)) timelineBeats) + (sendHeartbeats (Just "laptop") (Just $ ApiToken (toText $ token parsedConf)) timelineBeats) (mkEnv mgr parsedConf) case r of Left e -> print e