diff --git a/hikaru.cabal b/hikaru.cabal index 2d65f29c4fc66d5f72c5b3b9d23a00003510282c..b87781bf97893201c0b24e8fb60a65349bfb125f 100644 --- a/hikaru.cabal +++ b/hikaru.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: abedad9337bb68e5ffcb0364bf2152ac0633c4810698dfc652cd122bedd3290c +-- hash: e297323a7b6cecac97f8dd18ae01703782f331a12328a6934ad0a62d7cb0daf3 name: hikaru version: 0.1.0.0 @@ -52,7 +52,6 @@ library build-depends: aeson >=1.4 && <1.5 , base >=4.13 && <4.14 - , base-prelude >=1.3 && <1.4 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11 , case-insensitive >=1.2 && <1.3 @@ -63,6 +62,7 @@ library , http-types >=0.12 && <0.13 , lucid >=2.9 && <2.10 , mtl >=2.2 && <2.3 + , relude >=0.7 && <0.8 , resourcet >=1.2 && <1.3 , string-conversions >=0.4 && <0.5 , text >=1.2 && <1.3 @@ -91,7 +91,6 @@ test-suite spec build-depends: aeson >=1.4 && <1.5 , base >=4.13 && <4.14 - , base-prelude >=1.3 && <1.4 , binary >=0.8 && <0.9 , bytestring >=0.10 && <0.11 , case-insensitive >=1.2 && <1.3 @@ -104,6 +103,7 @@ test-suite spec , http-types >=0.12 && <0.13 , lucid >=2.9 && <2.10 , mtl >=2.2 && <2.3 + , relude >=0.7 && <0.8 , resourcet >=1.2 && <1.3 , string-conversions >=0.4 && <0.5 , text >=1.2 && <1.3 diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs index 35a3b58121b1268e6685eefa971d6319ac7a12ec..d13e91dc3250bd2e98325d5b60d4c4215176430e 100644 --- a/lib/Hikaru/Action.hs +++ b/lib/Hikaru/Action.hs @@ -104,8 +104,9 @@ module Hikaru.Action , FilePath ) where - import BasePrelude hiding (length) + import Relude + import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Configurator as Cfg import qualified Data.Configurator.Types as Cfg @@ -113,13 +114,13 @@ where import qualified Data.Text.Lazy as LT import qualified Network.Wai.Parse as Parse - import Control.Monad.Trans + import Control.Exception (throwIO, bracket_) import Control.Monad.Trans.Resource import Data.Aeson (Value, ToJSON, encode, eitherDecode') import Data.Binary.Builder - import Data.ByteString (ByteString, length) + import Data.Dynamic + import Data.List import Data.String.Conversions - import Data.Text (Text) import Hikaru.Media import Hikaru.Types import Lucid @@ -127,6 +128,7 @@ where import Network.HTTP.Types.Method import Network.HTTP.Types.Status import Network.Wai + import System.IO.Unsafe import Web.Cookie @@ -212,16 +214,16 @@ where -- -- Whole operation is bracketed to ensure all finalizers are run. -- - respond :: (ActionEnv -> IO ()) -> Cfg.Config -> Application - respond run cfg req resp = do - env <- makeActionEnv cfg req + respond :: (ActionEnv -> IO ()) -> Application + respond run req resp = do + env <- makeActionEnv req bracket_ (return ()) (finalize env) do _ <- run env - st <- readIORef $ env & aeRespStatus - hs <- readIORef $ env & aeRespHeaders - mk <- readIORef $ env & aeRespMaker + st <- readIORef $ aeRespStatus $ env + hs <- readIORef $ aeRespHeaders $ env + mk <- readIORef $ aeRespMaker $ env resp (mk st hs) @@ -526,7 +528,7 @@ where if haveRead < limit then do chunk <- getChunk - writeIORef counter $ haveRead + fromIntegral (length chunk) + writeIORef counter $ haveRead + fromIntegral (BS.length chunk) return chunk else do @@ -534,7 +536,7 @@ where where throwLimitIO :: Int64 -> IO a - throwLimitIO n = throwIO (PayloadTooLarge, cs msg :: Text) + throwLimitIO n = throwIO (PayloadTooLarge, msg :: Text) where msg = "Limit is " <> show n <> " bytes." @@ -810,9 +812,9 @@ where -- If the header has been given multiple times, leave only one. -- setHeader :: (MonadAction m) => HeaderName -> ByteString -> m () - setHeader n v = modifyActionField aeRespHeaders modify + setHeader n v = modifyActionField aeRespHeaders update where - modify hs = (n, v) : deleteBy headerEq (n, v) hs + update hs = (n, v) : deleteBy headerEq (n, v) hs -- | @@ -838,9 +840,9 @@ where -- modifyHeader :: (MonadAction m) => HeaderName -> (Maybe ByteString -> ByteString) -> m () - modifyHeader n fn = modifyActionField aeRespHeaders modify + modifyHeader n fn = modifyActionField aeRespHeaders update where - modify hs = (n, v') : deleteBy headerEq (n, v') hs + update hs = (n, v') : deleteBy headerEq (n, v') hs where v' = fn (lookup n hs) diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs index 67fc98cec3bba99dcbe69f4c8fe921814b7810a9..52e57c6c915402365d071d7e85f754f317c1ec1c 100644 --- a/lib/Hikaru/CSRF.hs +++ b/lib/Hikaru/CSRF.hs @@ -15,13 +15,12 @@ module Hikaru.CSRF , isTokenValid ) where - import BasePrelude + import Relude import Crypto.Hash import Crypto.MAC.HMAC - import Data.ByteString (ByteString) import Data.String.Conversions - import Data.Text (Text, splitOn) + import Data.Text (splitOn) import Data.Time.Clock.POSIX (getPOSIXTime) import Hikaru.Action @@ -36,7 +35,7 @@ where secret <- getConfigDefault "csrf.secret" "" let signature = sign now secret - in return $ mconcat [ cs (show now), ":", signature ] + in return $ mconcat [ show now, ":", signature ] -- | @@ -69,12 +68,11 @@ where sign :: Int64 -> Text -> Text - sign timestamp secret = cs $ show $ hmacGetDigest digest + sign timestamp secret = show $ hmacGetDigest digest where digest = hmac timeBytes secretBytes :: HMAC SHA256 secretBytes = cs secret :: ByteString - timeBytes = cs time :: ByteString - time = show timestamp + timeBytes = show timestamp :: ByteString -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Hikaru/Dispatch.hs b/lib/Hikaru/Dispatch.hs index 75dcb432d1ab9003ad484032f4c9fbbaaf9f7815..4d68d6ca035afb18d2395519795938404c69864f 100644 --- a/lib/Hikaru/Dispatch.hs +++ b/lib/Hikaru/Dispatch.hs @@ -30,17 +30,17 @@ module Hikaru.Dispatch , TopLevel ) where - import BasePrelude hiding (insert, lookup, app) - import qualified BasePrelude + import Relude - import Control.Monad.State (State, modify, execState) + import Control.Exception (catch) import Data.CaseInsensitive (original) - import Data.Map.Strict hiding (map) - import Data.Text (Text) - import Network.HTTP.Types.Header - import Network.Wai + import Data.List (lookup, deleteBy) import Hikaru.Route import Hikaru.Types + import Network.HTTP.Types.Header + import Network.Wai + + import qualified Data.Map.Strict as Map -- | @@ -120,7 +120,7 @@ where (\(exn, msg) -> mw (err exn msg) req' resp') err :: RequestError -> Text -> Application - err exn msg = case lookup exn envHandlers of + err exn msg = case Map.lookup exn envHandlers of Just eh -> runner (eh exn msg) Nothing -> defaultHandler exn msg @@ -135,8 +135,8 @@ where fixup = modifyHeader "Vary" (maybe value (<> ", " <> value)) value = mconcat $ intersperse ", " $ map original vs - modifyHeader n fn hs = (n, v') : deleteBy headerEq (n, v') hs - where v' = fn (BasePrelude.lookup n hs) + modifyHeader n fn hs = (n, v') : Data.List.deleteBy headerEq (n, v') hs + where v' = fn (Data.List.lookup n hs) headerEq (x, _) (y, _) = x == y @@ -221,7 +221,7 @@ where -> Dispatch r TopLevel () handler e h = Dispatch do modify \env@Env{envHandlers} -> - env { envHandlers = insert e h envHandlers } + env { envHandlers = Map.insert e h envHandlers } -- vim:set ft=haskell sw=2 ts=2 et: diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs index 8eb2b3da2fc1c3e0ae64c663d8b569760fd73f9e..662c41353baa166418860f6b75d9953420be1094 100644 --- a/lib/Hikaru/Form.hs +++ b/lib/Hikaru/Form.hs @@ -96,16 +96,16 @@ module Hikaru.Form , FromFormMessage(..) ) where - import BasePrelude hiding (Option, Control) + import Relude hiding (Option, show, elem) - import Control.Monad.Reader (ReaderT, runReaderT, ask) - import Control.Monad.State (StateT, runStateT, execStateT, modify, get) - import Control.Monad.Trans (MonadTrans, lift) - import Data.Text (Text, strip) + import Data.Dynamic + import Data.List + import Data.Text (strip) import Hikaru.Action import Hikaru.CSRF import Hikaru.Localize import Hikaru.Types + import Text.Show data Env o @@ -585,8 +585,8 @@ where new <- lift $ lift do let field = InputField "hidden" Nothing text - state = ControlState name field [] [] val - in flip execStateT state $ flip runReaderT env $ runControlT body + ctrst = ControlState name field [] [] val + in flip execStateT ctrst $ flip runReaderT env $ runControlT body ctrl <- lift $ lift $ buildControl env new @@ -613,8 +613,8 @@ where new <- lift $ lift do let field = InputField "hidden" Nothing text - state = ControlState name field [] [] val - in flip execStateT state $ flip runReaderT env $ runControlT body + ctrst = ControlState name field [] [] val + in flip execStateT ctrst $ flip runReaderT env $ runControlT body ctrl <- lift $ lift $ buildControl env new @@ -658,8 +658,8 @@ where new <- lift $ lift do let field = InputField "text" Nothing text - state = ControlState name field [] [] val - in flip execStateT state $ flip runReaderT env $ runControlT body + ctrst = ControlState name field [] [] val + in flip execStateT ctrst $ flip runReaderT env $ runControlT body ctrl <- lift $ lift $ buildControl env new @@ -701,8 +701,8 @@ where new <- lift $ lift do let val' = val <|> (getter <$> envValue) field = SelectField [] - state = ControlState name field [] [] val' - in flip execStateT state $ flip runReaderT env $ runControlT body + ctrst = ControlState name field [] [] val' + in flip execStateT ctrst $ flip runReaderT env $ runControlT body ctrl <- lift $ lift $ buildControl env new @@ -813,11 +813,11 @@ where dumpControl :: (MonadIO m, Show l, Show o, Show v) => ControlT t l o v m () dumpControl = ControlT do - state <- get + ctrst <- get liftIO do putStr "Control Dump:\n " - putStrLn (show state) + putStrLn (show ctrst) -- Internal ---------------------------------------------------------------- diff --git a/lib/Hikaru/Link.hs b/lib/Hikaru/Link.hs index 503184d0210c1e102ad53da1733b43dea8a176c8..4410ae590987a649616951e1c8ac1977e30b7e4a 100644 --- a/lib/Hikaru/Link.hs +++ b/lib/Hikaru/Link.hs @@ -25,12 +25,10 @@ module Hikaru.Link , isActivePrefix ) where - import BasePrelude + import Relude import Data.Binary.Builder - import Data.ByteString (ByteString) import Data.String.Conversions - import Data.Text (Text) import Lucid import Network.HTTP.Types.URI import Hikaru.Action diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs index cc529266426c1e1004fd6e4a0faf3e1c41bc944f..1882e82740f35091a23a31451a93374aeea9cdfc 100644 --- a/lib/Hikaru/Localize.hs +++ b/lib/Hikaru/Localize.hs @@ -64,13 +64,13 @@ module Hikaru.Localize , selectLanguages ) where - import BasePrelude + import Relude + import Data.List import Data.String.Conversions - import Data.Text (Text) - import Lucid import Hikaru.Action import Hikaru.Media + import Lucid -- | @@ -122,14 +122,14 @@ where -- | -- Localize given message to the language indicated by the - -- 'getLanguages' of the current action. Uses 'localize' internally. + -- 'getLanguages' of the current action. Uses 'localize' internaly. -- lc :: (MonadAction m, Localizable l) => l -> m Text lc msg = do langs <- getLanguages case mapMaybe (flip localize msg) langs of - [] -> return $ cs $ show msg + [] -> return $ show msg x:_ -> return x @@ -142,7 +142,7 @@ where langs <- getLanguages case mapMaybe (flip localizeHtml msg) langs of - [] -> toHtml $ show msg + [] -> toHtml $ (show msg :: Text) x:_ -> x diff --git a/lib/Hikaru/Media.hs b/lib/Hikaru/Media.hs index b143df188e3180717fd67dd0ee73dd717b9a1bad..dd6c8a2f0f3355e51f762012f2af06c65b91db65 100644 --- a/lib/Hikaru/Media.hs +++ b/lib/Hikaru/Media.hs @@ -24,10 +24,10 @@ module Hikaru.Media , selectMedia ) where - import BasePrelude hiding (group, find) + import Relude hiding (group, find, head) + import Relude.Unsafe (head) import Data.String.Conversions - import Data.Text (Text) import Data.Text.ICU diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs index be6b572515e75f790c8ce1d39257c0ec43188430..fe8742f1e29fe4768542427035872989263cddb7 100644 --- a/lib/Hikaru/Route.hs +++ b/lib/Hikaru/Route.hs @@ -55,11 +55,10 @@ module Hikaru.Route , Route ) where - import BasePrelude hiding (head, delete) + import Relude hiding (get, put, head) - import Data.ByteString (ByteString) import Data.String.Conversions - import Data.Text (Text) + import Data.List (lookup) import Network.HTTP.Types.Header import Network.HTTP.Types.Method (Method) import Network.Wai @@ -208,7 +207,7 @@ where -- Select the best route with respect to the request. -- choosePath :: Request -> [Request -> RouteResult a] -> RouteResult a - choosePath req = choose . map (req &) + choosePath req = choose . map ($ req) where choose :: [RouteResult a] -> RouteResult a choose [] = RouteFailed NotFound "" [] diff --git a/lib/Hikaru/Types.hs b/lib/Hikaru/Types.hs index 115e11c7a9a285946924f4561f1a869666874e6f..8394f9a3d52503b788cc8bb6ad609dd2bf664650 100644 --- a/lib/Hikaru/Types.hs +++ b/lib/Hikaru/Types.hs @@ -17,11 +17,11 @@ module Hikaru.Types , defaultHandler ) where - import BasePrelude + import Relude import Data.ByteString (ByteString) import Data.String.Conversions - import Data.Text (Text, pack, unpack) + import Data.Text (pack, unpack) import Network.HTTP.Types.Header import Network.HTTP.Types.Status import Network.Wai diff --git a/package.yaml b/package.yaml index d697cb7800bbb2ec4d395b10936bd343d3c9e6e0..d493b40f2f3d0f2d68896514390b4bf7c119d26b 100644 --- a/package.yaml +++ b/package.yaml @@ -45,7 +45,7 @@ default-extensions: dependencies: - aeson >= 1.4 && <1.5 - base >= 4.13 && <4.14 - - base-prelude >= 1.3 && <1.4 + - relude >= 0.7 && <0.8 - binary >= 0.8 && <0.9 - bytestring >= 0.10 && <0.11 - case-insensitive >= 1.2 && <1.3 diff --git a/test/Hikaru/Demo.hs b/test/Hikaru/Demo.hs index f4b68a6bdd0b922af9c10bca5d4c99a57474dda2..4bc1e735f967e6f0f26a53045163198476d875a9 100644 --- a/test/Hikaru/Demo.hs +++ b/test/Hikaru/Demo.hs @@ -12,11 +12,10 @@ module Hikaru.Demo ( makeDemo ) where - import BasePrelude hiding (for_, Option, Control) + import Relude hiding (for_, Option, get) - import Control.Monad.Reader + import Control.Concurrent.MVar (modifyMVar_) import Data.Aeson () - import Data.Text (Text) import Hikaru import Lucid import Network.HTTP.Types.Header @@ -146,7 +145,7 @@ where -- Present fancy HTML result. sendHTML do h1_ "Welcome!" - p_ $ "You are " >> toHtml (show n) >> ". visitor!" + p_ $ "You are " >> toHtml (show n :: Text) >> ". visitor!" getRootTextR :: Action () @@ -155,9 +154,9 @@ where n <- countVisitor -- Present a plain textual result. - sendString $ unlines [ "Welcome!" - , "You are " <> show n <> ". visitor!" - ] + sendText $ unlines [ "Welcome!" + , "You are " <> show n <> ". visitor!" + ] postEchoR :: Action () @@ -211,13 +210,13 @@ where th_ "Mode" th_ "Active" - for cases \Case{..} -> do + forM cases \Case{..} -> do tr_ do - td_ $ toHtml $ show caseId + td_ $ toHtml $ (show caseId :: Text) td_ $ toHtml $ caseName td_ $ toHtml $ caseRecNo - td_ $ toHtml $ show caseMode - td_ $ toHtml $ show caseActive + td_ $ toHtml $ (show caseMode :: Text) + td_ $ toHtml $ (show caseActive :: Text) -- Forms ------------------------------------------------------------------- diff --git a/test/Hikaru/DemoSpec.hs b/test/Hikaru/DemoSpec.hs index 35f0057bd4558e4627807e832d60785f4653bfef..161e9e551cd55516b06dde04f8d5fa51bac55288 100644 --- a/test/Hikaru/DemoSpec.hs +++ b/test/Hikaru/DemoSpec.hs @@ -14,10 +14,11 @@ module Hikaru.DemoSpec ( spec ) where - import BasePrelude + import Relude hiding (get) import Hikaru.Demo import Hikaru.Test + import System.IO.Unsafe spec :: Spec diff --git a/test/Hikaru/FormSpec.hs b/test/Hikaru/FormSpec.hs index a845d7c1e73727053c9e8350123bf6441dca8306..e2a9e4bb63b193d2513182431bb2adbad03541e9 100644 --- a/test/Hikaru/FormSpec.hs +++ b/test/Hikaru/FormSpec.hs @@ -12,7 +12,7 @@ module Hikaru.FormSpec ( spec ) where - import BasePrelude + import Relude import Hikaru () import Hikaru.Test diff --git a/test/Hikaru/Test.hs b/test/Hikaru/Test.hs index 5941094b574eb80eb61632bc8878d540cf9130cb..23626fe306bc4a542b60fff8200c9eb8e3b9dc0b 100644 --- a/test/Hikaru/Test.hs +++ b/test/Hikaru/Test.hs @@ -21,11 +21,10 @@ module Hikaru.Test , module Test.Hspec ) where - import BasePrelude + import Relude hiding (get) - import qualified Data.ByteString.Lazy as Lazy + import qualified Data.ByteString.Lazy as LBS - import Data.ByteString (ByteString) import Network.HTTP.Types import Network.Wai import Network.Wai.Internal @@ -45,7 +44,7 @@ where post path headers body = srequest sreq where req = setPath defaultRequest path - sreq = SRequest { simpleRequestBody = Lazy.fromStrict body + sreq = SRequest { simpleRequestBody = LBS.fromStrict body , simpleRequest = req { requestMethod = methodPost , requestHeaders = headers }