From ca1a3d1e6e181fffd1030c6c49853751be8e9e43 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Jan=20Hamal=20Dvo=C5=99=C3=A1k?= <mordae@anilinux.org>
Date: Thu, 13 Jan 2022 14:48:00 +0100
Subject: [PATCH] Get ready for GHC 9.2
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Signed-off-by: Jan Hamal Dvořák <mordae@anilinux.org>
---
hikaru.cabal | 204 ++++++++++++++++++++---------------------
lib/Hikaru/Action.hs | 101 ++++++++++----------
lib/Hikaru/CSRF.hs | 36 +++++---
lib/Hikaru/Form.hs | 28 +++---
lib/Hikaru/Localize.hs | 4 +-
lib/Hikaru/Media.hs | 10 +-
lib/Hikaru/Route.hs | 7 +-
7 files changed, 195 insertions(+), 195 deletions(-)
diff --git a/hikaru.cabal b/hikaru.cabal
index 1107d44..8559e1f 100644
--- a/hikaru.cabal
+++ b/hikaru.cabal
@@ -1,17 +1,14 @@
-cabal-version: 3.0
-
-name: hikaru
-version: 0.2.0.0
-homepage: https://github.com/mordae/hikaru#readme
-bug-reports: https://github.com/mordae/hikaru/issues
-
-license: MIT
-license-file: LICENSE
-copyright: Jan Hamal Dvořák
-maintainer: mordae@anilinux.org
-author: Jan Hamal Dvořák
-
-synopsis: Haskell web application framework
+cabal-version: 3.0
+name: hikaru
+version: 0.3.0
+license: MIT
+license-file: LICENSE
+copyright: Jan Hamal Dvořák
+maintainer: mordae@anilinux.org
+author: Jan Hamal Dvořák
+homepage: https://github.com/mordae/hikaru#readme
+bug-reports: https://github.com/mordae/hikaru/issues
+synopsis: Haskell web application framework
description:
Hikaru is a small framework for web applications.
It provides applicative routing, content negotiation
@@ -20,87 +17,15 @@ description:
(It is also a Star Trek reference, which is apparently
a requirement for this class of software.)
-category: Web
-build-type: Simple
+category: Web
+build-type: Simple
extra-source-files: README.md
source-repository head
- type: git
+ type: git
location: https://github.com/mordae/hikaru
-common common
- default-language: Haskell2010
-
- default-extensions:
- AllowAmbiguousTypes
- BangPatterns
- BlockArguments
- ConstraintKinds
- DataKinds
- DefaultSignatures
- DeriveGeneric
- DuplicateRecordFields
- EmptyDataDecls
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving
- ImportQualifiedPost
- KindSignatures
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- NoImplicitPrelude
- OverloadedStrings
- PolyKinds
- RankNTypes
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- TupleSections
- TypeApplications
- TypeFamilies
- TypeOperators
- UndecidableInstances
-
- ghc-options:
- -Wall
- -Wcompat
- -Wincomplete-uni-patterns
- -Wincomplete-record-updates
- -Widentities
- -Wredundant-constraints
-
- build-depends:
- , aeson >=1.4 && <1.6
- , attoparsec >=0.13 && <0.15
- , base >=4.13 && <5
- , binary >=0.8 && <0.9
- , bytestring >=0.10 && <0.12
- , case-insensitive >=1.2 && <1.3
- , containers >=0.6 && <0.7
- , cookie >=0.4 && <0.5
- , cryptonite >=0.26 && <0.29
- , foreign-store >=0.2 && <0.3
- , http-types >=0.12 && <0.13
- , hvect >=0.4 && <0.5
- , lucid >=2.9 && <2.10
- , memory >=0.15 && <0.16
- , mtl >=2.2 && <2.3
- , praha >=0.1 && <0.2
- , praha-config >=0.1 && <0.2
- , resourcet >=1.2 && <1.3
- , text >=1.2 && <1.3
- , time >=1.9 && <1.12
- , unliftio >=0.2 && <0.3
- , wai >=3.2 && <3.3
- , wai-extra >=3.0 && <3.2
- , wai-websockets >=3.0 && <3.1
- , websockets >=0.12 && <0.13
-
-
library
- import: common
-
exposed-modules:
Hikaru
Hikaru.Develop
@@ -115,21 +40,57 @@ library
Hikaru.Route
Hikaru.Types
- hs-source-dirs: lib
- other-modules:
- Paths_hikaru
+ hs-source-dirs: lib
+ other-modules: Paths_hikaru
+ default-language: Haskell2010
+ default-extensions:
+ AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds
+ DataKinds DefaultSignatures DeriveGeneric DuplicateRecordFields
+ EmptyDataDecls FlexibleContexts FlexibleInstances
+ GeneralizedNewtypeDeriving ImportQualifiedPost KindSignatures
+ LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude
+ OverloadedStrings PolyKinds RankNTypes RecordWildCards
+ ScopedTypeVariables StandaloneDeriving TupleSections
+ TypeApplications TypeFamilies TypeOperators UndecidableInstances
+ DisambiguateRecordFields NoFieldSelectors OverloadedRecordDot
ghc-options:
+ -Wall -Wcompat -Wincomplete-uni-patterns
+ -Wincomplete-record-updates -Widentities -Wredundant-constraints
-Wunused-packages
-test-suite spec
- import: common
+ build-depends:
+ aeson >=1.4,
+ attoparsec >=0.13,
+ base >=4.13 && <5,
+ binary >=0.8,
+ bytestring >=0.10,
+ case-insensitive >=1.2,
+ containers >=0.6,
+ cookie >=0.4,
+ foreign-store >=0.2,
+ http-types >=0.12,
+ hvect >=0.4,
+ lucid >=2.9,
+ mtl >=2.2,
+ praha >=0.1,
+ praha-config >=0.1,
+ resourcet >=1.2,
+ text >=1.2,
+ time >=1.9,
+ unliftio >=0.2,
+ wai >=3.2,
+ wai-extra >=3.0,
+ wai-websockets >=3.0,
+ websockets >=0.12,
+ HsOpenSSL >=0.11
- type: exitcode-stdio-1.0
- main-is: Spec.hs
- build-tool-depends: hspec-discover:hspec-discover -any
- cpp-options: -DTEST
- hs-source-dirs: test
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Spec.hs
+ build-tool-depends: hspec-discover:hspec-discover
+ cpp-options: -DTEST
+ hs-source-dirs: test
other-modules:
Hikaru.Demo
Hikaru.DemoSpec
@@ -137,11 +98,46 @@ test-suite spec
Hikaru.Test
Paths_hikaru
+ default-language: Haskell2010
+ default-extensions:
+ AllowAmbiguousTypes BangPatterns BlockArguments ConstraintKinds
+ DataKinds DefaultSignatures DeriveGeneric DuplicateRecordFields
+ EmptyDataDecls FlexibleContexts FlexibleInstances
+ GeneralizedNewtypeDeriving ImportQualifiedPost KindSignatures
+ LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude
+ OverloadedStrings PolyKinds RankNTypes RecordWildCards
+ ScopedTypeVariables StandaloneDeriving TupleSections
+ TypeApplications TypeFamilies TypeOperators UndecidableInstances
+ DisambiguateRecordFields NoFieldSelectors OverloadedRecordDot
+
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
+ -Wall -Wcompat -Wincomplete-uni-patterns
+ -Wincomplete-record-updates -Widentities -Wredundant-constraints
+ -threaded -rtsopts -with-rtsopts=-N
build-depends:
- hikaru -any
- , hspec -any
+ aeson >=1.4,
+ attoparsec >=0.13,
+ base >=4.13 && <5,
+ binary >=0.8,
+ bytestring >=0.10,
+ case-insensitive >=1.2,
+ containers >=0.6,
+ cookie >=0.4,
+ foreign-store >=0.2,
+ http-types >=0.12,
+ hvect >=0.4,
+ lucid >=2.9,
+ mtl >=2.2,
+ praha >=0.1,
+ praha-config >=0.1,
+ resourcet >=1.2,
+ text >=1.2,
+ time >=1.9,
+ unliftio >=0.2,
+ wai >=3.2,
+ wai-extra >=3.0,
+ wai-websockets >=3.0,
+ websockets >=0.12,
+ hikaru,
+ hspec
diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs
index 71cf179..077d1b4 100644
--- a/lib/Hikaru/Action.hs
+++ b/lib/Hikaru/Action.hs
@@ -122,7 +122,6 @@ where
import Control.Monad.Trans.Resource
import Data.Aeson
import Data.Binary.Builder
- import Data.ByteArray.Encoding
import Data.ByteString.Char8 (words, span, drop)
import Data.CaseInsensitive (mk)
import Data.Dynamic
@@ -135,6 +134,7 @@ where
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Handler.WebSockets
+ import OpenSSL.EVP.Base64
import System.IO.Unsafe
import UnliftIO
import Web.Cookie
@@ -250,15 +250,15 @@ where
bracket_ (return ()) (finalize env) do
_ <- run env
- status <- readIORef $ aeRespStatus $ env
- headers <- readIORef $ aeRespHeaders $ env
- make <- readIORef $ aeRespMaker $ env
+ status <- readIORef $ env.aeRespStatus
+ headers <- readIORef $ env.aeRespHeaders
+ make <- readIORef $ env.aeRespMaker
resp (make status headers)
where
finalize :: ActionEnv -> IO ()
- finalize = join . readIORef . aeFinalize
+ finalize = join . readIORef . (.aeFinalize)
-- |
@@ -320,7 +320,7 @@ where
-- Obtain the original 'Request'.
--
getRequest :: (MonadAction m) => m Request
- getRequest = aeRequest <$> getActionEnv
+ getRequest = (.aeRequest) <$> getActionEnv
-- |
@@ -553,14 +553,14 @@ where
-- length is not known beforehand.
--
setBodyLimit :: (MonadAction m) => Int64 -> m ()
- setBodyLimit = setActionField aeBodyLimit
+ setBodyLimit = setActionField (.aeBodyLimit)
-- |
-- Return the payload size limit set by 'setBodyLimit'.
--
getBodyLimit :: (MonadAction m) => m Int64
- getBodyLimit = getActionField aeBodyLimit
+ getBodyLimit = getActionField (.aeBodyLimit)
-- |
@@ -587,8 +587,8 @@ where
--
getBodyChunkIO :: (MonadAction m) => m (IO ByteString)
getBodyChunkIO = do
- limit <- getActionField aeBodyLimit
- counter <- aeBodyCounter <$> getActionEnv
+ limit <- getActionField (.aeBodyLimit)
+ counter <- (.aeBodyCounter) <$> getActionEnv
getChunk <- getRequestBodyChunk <$> getRequest
return do
@@ -652,7 +652,7 @@ where
getJSON :: (MonadAction m, FromJSON a) => m a
getJSON = do
-- First check out our stash.
- cache <- getActionField aeBody
+ cache <- getActionField (.aeBody)
case cache of
-- This is ideal, we already have what we need.
@@ -670,7 +670,7 @@ where
else abort unsupportedMediaType415 [] "Send some JSON!"
-- Taint and read.
- setActionField aeBody BodyTainted
+ setActionField (.aeBody) BodyTainted
body <- getBodyRaw
-- Try to parse.
@@ -679,7 +679,7 @@ where
Right value -> return value
-- Cache and return.
- setActionField aeBody (BodyJSON value)
+ setActionField (.aeBody) (BodyJSON value)
-- Parse to the output type.
case fromJSON value of
@@ -781,7 +781,7 @@ where
--
getFormData :: (MonadAction m) => m FormData
getFormData = do
- cache <- getActionField aeBody
+ cache <- getActionField (.aeBody)
case cache of
-- This is ideal, we already have what we need.
@@ -807,7 +807,7 @@ where
let form = adaptForm form'
-- Cache and return.
- setActionField aeBody (BodyForm form)
+ setActionField (.aeBody) (BodyForm form)
return form
-- Now this is bad. We have already read the body,
@@ -837,7 +837,7 @@ where
--
getBody :: (MonadAction m) => m LBS.ByteString
getBody = do
- cache <- getActionField aeBody
+ cache <- getActionField (.aeBody)
case cache of
-- This is ideal, we already have what we need.
@@ -846,14 +846,14 @@ where
-- Body has not been parsed yet. This is very good.
BodyUnparsed -> do
-- Taint and read.
- setActionField aeBody BodyTainted
+ setActionField (.aeBody) BodyTainted
body <- getBodyRaw
-- Force it whole.
_len <- LBS.length <$> pure body
-- Cache and return.
- setActionField aeBody (BodyBytes body)
+ setActionField (.aeBody) (BodyBytes body)
return body
-- Now this is bad. We have already read the body,
@@ -869,21 +869,21 @@ where
-- Set the status to use when building our 'Response'.
--
setStatus :: (MonadAction m) => Status -> m ()
- setStatus = setActionField aeRespStatus
+ setStatus = setActionField (.aeRespStatus)
-- |
-- Set headers to use when building our 'Response'.
--
setHeaders :: (MonadAction m) => ResponseHeaders -> m ()
- setHeaders = setActionField aeRespHeaders
+ setHeaders = setActionField (.aeRespHeaders)
-- |
-- Append a single 'Response' header without checking.
--
addHeader :: (MonadAction m) => HeaderName -> ByteString -> m ()
- addHeader n v = modifyActionField aeRespHeaders ((n, v) :)
+ addHeader n v = modifyActionField (.aeRespHeaders) ((n, v) :)
-- |
@@ -891,7 +891,7 @@ where
-- If the header has been given multiple times, leave only one.
--
setHeader :: (MonadAction m) => HeaderName -> ByteString -> m ()
- setHeader n v = modifyActionField aeRespHeaders update
+ setHeader n v = modifyActionField (.aeRespHeaders) update
where
update hs = (n, v) : deleteBy headerEq (n, v) hs
@@ -919,7 +919,7 @@ where
--
modifyHeader :: (MonadAction m)
=> HeaderName -> (Maybe ByteString -> ByteString) -> m ()
- modifyHeader n fn = modifyActionField aeRespHeaders update
+ modifyHeader n fn = modifyActionField (.aeRespHeaders) update
where
update hs = (n, v') : deleteBy headerEq (n, v') hs
where v' = fn (lookup n hs)
@@ -1017,7 +1017,7 @@ where
--
setResponseFile :: (MonadAction m) => FilePath -> Maybe FilePart -> m ()
setResponseFile fp mfp = do
- setActionField aeRespMaker \st hs -> responseFile st hs fp mfp
+ setActionField (.aeRespMaker) \st hs -> responseFile st hs fp mfp
-- |
@@ -1025,7 +1025,7 @@ where
--
setResponseBuilder :: (MonadAction m) => Builder -> m ()
setResponseBuilder bld = do
- setActionField aeRespMaker \st hs -> responseBuilder st hs bld
+ setActionField (.aeRespMaker) \st hs -> responseBuilder st hs bld
-- |
@@ -1033,7 +1033,7 @@ where
--
setResponseBS :: (MonadAction m) => LBS.ByteString -> m ()
setResponseBS bs = do
- setActionField aeRespMaker \st hs -> responseLBS st hs bs
+ setActionField (.aeRespMaker) \st hs -> responseLBS st hs bs
-- |
@@ -1069,7 +1069,7 @@ where
--
setResponseStream :: (MonadAction m) => StreamingBody -> m ()
setResponseStream strm = do
- setActionField aeRespMaker \st hs -> responseStream st hs strm
+ setActionField (.aeRespMaker) \st hs -> responseStream st hs strm
-- |
@@ -1091,7 +1091,7 @@ where
-> Response
-> m ()
setResponseRaw comm resp = do
- setActionField aeRespMaker \_st _hs -> responseRaw comm resp
+ setActionField (.aeRespMaker) \_st _hs -> responseRaw comm resp
-- WebSockets --------------------------------------------------------------
@@ -1107,7 +1107,7 @@ where
-- to communicate in one way only.
--
setFrameLimit :: (MonadAction m) => Int64 -> m ()
- setFrameLimit = setActionField aeFrameLimit
+ setFrameLimit = setActionField (.aeFrameLimit)
-- |
@@ -1122,7 +1122,7 @@ where
-- Single message may or may not consist of multiple frames.
--
setMessageLimit :: (MonadAction m) => Int64 -> m ()
- setMessageLimit = setActionField aeMsgLimit
+ setMessageLimit = setActionField (.aeMsgLimit)
-- |
@@ -1133,14 +1133,14 @@ where
-- Sets up an automatic keep-alive with a 30s ping interval.
--
setResponseWS :: (MonadAction m) => WebSocket () -> m ()
- setResponseWS ws = do
+ setResponseWS WebSocket{runWebSocket} = do
-- First check the body situation.
- body <- getActionField aeBody
+ body <- getActionField (.aeBody)
case body of
BodyUnparsed -> do
- frameLimit <- WS.SizeLimit <$> getActionField aeFrameLimit
- messageLimit <- WS.SizeLimit <$> getActionField aeMsgLimit
+ frameLimit <- WS.SizeLimit <$> getActionField (.aeFrameLimit)
+ messageLimit <- WS.SizeLimit <$> getActionField (.aeMsgLimit)
let opts = WS.defaultConnectionOptions
{ WS.connectionFramePayloadSizeLimit = frameLimit
@@ -1149,8 +1149,8 @@ where
req <- getRequest
- setActionField aeBody BodyWebSocket
- setActionField aeRespMaker \_st _hs ->
+ setActionField (.aeBody) BodyWebSocket
+ setActionField (.aeRespMaker) \_st _hs ->
case websocketsApp opts app req of
Nothing -> responseLBS status400 [] "WebSocket Expected"
Just resp -> resp
@@ -1164,7 +1164,7 @@ where
void do
conn <- WS.acceptRequest pc
WS.withPingThread conn 30 (return ()) do
- runReaderT (unWebSocket ws) conn
+ runReaderT runWebSocket conn
-- |
@@ -1172,7 +1172,7 @@ where
--
newtype WebSocket a
= WebSocket
- { unWebSocket :: ReaderT WS.Connection IO a
+ { runWebSocket :: ReaderT WS.Connection IO a
}
deriving (MonadUnliftIO, MonadIO, Monad, Applicative, Functor)
@@ -1247,7 +1247,7 @@ where
-- the localization tools found in the "Hikaru.Localize" module.
--
getLanguages :: (MonadAction m) => m [Text]
- getLanguages = getActionField aeLanguages
+ getLanguages = getActionField (.aeLanguages)
-- |
@@ -1256,7 +1256,7 @@ where
-- See 'getLanguages' above for more information.
--
setLanguages :: (MonadAction m) => [Text] -> m ()
- setLanguages = setActionField aeLanguages
+ setLanguages = setActionField (.aeLanguages)
-- Cacheing ----------------------------------------------------------------
@@ -1279,12 +1279,12 @@ where
--
withCache :: (MonadAction m, Typeable a) => Text -> m a -> m a
withCache key makeValue = do
- cache <- getActionField aeCache
+ cache <- getActionField (.aeCache)
case fromDynamic =<< Map.lookup key cache of
Nothing -> do
value <- makeValue
- modifyActionField aeCache (Map.insert key (toDyn value))
+ modifyActionField (.aeCache) (Map.insert key (toDyn value))
return value
Just value -> do
@@ -1296,7 +1296,7 @@ where
--
dropCache :: (MonadAction m) => Text -> m ()
dropCache key = do
- modifyActionField aeCache (Map.delete key)
+ modifyActionField (.aeCache) (Map.delete key)
-- |
@@ -1304,7 +1304,7 @@ where
--
dropCaches :: (MonadAction m) => m ()
dropCaches = do
- modifyActionField aeCache (const Map.empty)
+ modifyActionField (.aeCache) (const Map.empty)
-- Finalizing --------------------------------------------------------------
@@ -1316,7 +1316,7 @@ where
--
registerFinalizer :: (MonadAction m) => IO a -> m ()
registerFinalizer fin = do
- modifyActionField aeFinalize (fin >>)
+ modifyActionField (.aeFinalize) (fin >>)
-- Misc Utilities ----------------------------------------------------------
@@ -1337,18 +1337,13 @@ where
cs2 (x, y) = (cs x, cs y)
- decodeBase64 :: ByteString -> Either String ByteString
- decodeBase64 bstr = convertFromBase Base64 bstr
-
-
parseBasicAuth :: ByteString -> Maybe (Text, Text)
parseBasicAuth value =
case words value of
[method, auth] | mk method == "Basic" -> do
- case decodeBase64 auth of
- Left _ -> Nothing
- Right lp -> let (l, p) = span (/= ':') lp
- in Just (cs l, cs (drop 1 p))
+ let lp = decodeBase64BS (cs auth)
+ (l, p) = span (/= ':') lp
+ in Just (cs l, cs (drop 1 p))
_otherwise -> Nothing
diff --git a/lib/Hikaru/CSRF.hs b/lib/Hikaru/CSRF.hs
index 7252242..0d1f2ec 100644
--- a/lib/Hikaru/CSRF.hs
+++ b/lib/Hikaru/CSRF.hs
@@ -18,18 +18,26 @@ where
import Praha
import Praha.Config.Environment
- import Crypto.Hash
- import Crypto.MAC.HMAC
- import Crypto.Random.Entropy
+ import System.IO.Unsafe
+
+ import OpenSSL
+ import OpenSSL.Random
+ import OpenSSL.EVP.Base64
+ import OpenSSL.EVP.Digest
import Data.Text (splitOn)
import Data.Time.Clock.POSIX (getPOSIXTime)
- import Data.ByteArray.Encoding
-
import Hikaru.Action
+ sha256 :: Digest
+ sha256 = case unsafePerformIO (withOpenSSL (getDigestByName "sha256")) of
+ Nothing -> error "OpenSSL does not provide sha256"
+ Just dg -> dg
+ {-# NOINLINE sha256 #-}
+
+
-- |
-- Generate an anti-CSRF token to be used with forms.
--
@@ -40,7 +48,7 @@ where
now <- getTimestamp
secret <- getSecret
- let signature = sign now secret
+ let signature = sign secret now
in return $ mconcat [ tshow now, ":", signature ]
@@ -61,7 +69,7 @@ where
secret <- getConfigDefault "CSRF_SECRET" ""
if timestamp + valid >= now
- then return (sign timestamp secret == signature)
+ then return (sign secret timestamp == signature)
else return False
Nothing -> return False
@@ -91,12 +99,12 @@ where
return secret
- sign :: Int64 -> Text -> Text
- sign timestamp secret = tshow $ hmacGetDigest digest
+ sign :: Text -> Int64 -> Text
+ sign secret timestamp = cs signature
where
- digest = hmac timeBytes secretBytes :: HMAC SHA256
- secretBytes = cs secret :: ByteString
- timeBytes = cs (show timestamp) :: ByteString
+ signature = hmacBS sha256 secretBytes timeBytes
+ secretBytes = cs secret
+ timeBytes = cs (show timestamp)
-- |
@@ -105,9 +113,9 @@ where
--
generateSecret :: (MonadIO m) => Int -> m Text
generateSecret n = do
- (bstr :: ByteString) <- liftIO $ getEntropy n
+ (bstr :: ByteString) <- liftIO $ prandBytes n
- let (bstr64 :: ByteString) = convertToBase Base64 bstr
+ let bstr64 = encodeBase64BS bstr
in return (cs bstr64)
diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs
index f3cae9b..b4d3b7e 100644
--- a/lib/Hikaru/Form.hs
+++ b/lib/Hikaru/Form.hs
@@ -177,8 +177,8 @@ where
{-# INLINE pure #-}
l <*> r = FormT do
- l' <- runFormT l
- r' <- runFormT r
+ l' <- l.runFormT
+ r' <- r.runFormT
return $ l' <*> r'
{-# INLINE (<*>) #-}
@@ -217,8 +217,8 @@ where
{-# INLINE pure #-}
l <*> r = ElementT do
- l' <- runElementT l
- r' <- runElementT r
+ l' <- l.runElementT
+ r' <- r.runElementT
return $ l' <*> r'
{-# INLINE (<*>) #-}
@@ -455,7 +455,7 @@ where
-- @
--
newForm :: (Monad m) => Text -> Maybe o -> Form l m o -> m (View l)
- newForm name orig = flip execStateT view . flip runReaderT env . runFormT
+ newForm name orig = flip execStateT view . flip runReaderT env . (.runFormT)
where
view = View [] []
env = Env { envPrefix = name
@@ -583,7 +583,7 @@ where
(res, new) <- lift $ lift do
let base = Element label []
- in flip runStateT base $ flip runReaderT env $ runElementT body
+ in flip runStateT base $ flip runReaderT env $ body.runElementT
modify \view@View{..} ->
view { viewElements = viewElements <> [new] }
@@ -608,14 +608,14 @@ where
new <- lift $ lift do
let field = InputField "hidden" Nothing text
ctrst = ControlState name field [] [] val
- in flip execStateT ctrst $ flip runReaderT env $ runControlT body
+ in flip execStateT ctrst $ flip runReaderT env $ body.runControlT
ctrl <- lift $ lift $ buildControl env new
modify \view@View{..} ->
view { viewControls = viewControls <> [ctrl] }
- return $ csValue new
+ return $ new.csValue
-- |
@@ -636,14 +636,14 @@ where
new <- lift $ lift do
let field = InputField "hidden" Nothing text
ctrst = ControlState name field [] [] val
- in flip execStateT ctrst $ flip runReaderT env $ runControlT body
+ in flip execStateT ctrst $ flip runReaderT env $ body.runControlT
ctrl <- lift $ lift $ buildControl env new
modify \view@View{..} ->
view { viewControls = viewControls <> [ctrl] }
- return $ csValue new
+ return $ new.csValue
-- |
@@ -681,14 +681,14 @@ where
new <- lift $ lift do
let field = InputField "text" Nothing text
ctrst = ControlState name field [] [] val
- in flip execStateT ctrst $ flip runReaderT env $ runControlT body
+ in flip execStateT ctrst $ flip runReaderT env $ body.runControlT
ctrl <- lift $ lift $ buildControl env new
modify \elt@Element{..} ->
elt { elemControls = elemControls <> [ctrl] }
- return $ csValue new
+ return $ new.csValue
-- |
@@ -727,14 +727,14 @@ where
let val' = val <|> (getter <$> envValue)
field = SelectField []
ctrst = ControlState name field [] [] val'
- in flip execStateT ctrst $ flip runReaderT env $ runControlT body
+ in flip execStateT ctrst $ flip runReaderT env $ body.runControlT
ctrl <- lift $ lift $ buildControl env new
modify \elt@Element{..} ->
elt { elemControls = elemControls <> [ctrl] }
- return $ csValue new
+ return $ new.csValue
-- |
diff --git a/lib/Hikaru/Localize.hs b/lib/Hikaru/Localize.hs
index 3c54031..52234ea 100644
--- a/lib/Hikaru/Localize.hs
+++ b/lib/Hikaru/Localize.hs
@@ -157,8 +157,8 @@ where
preferred <- getParamMaybe paramName
previous <- getCookieMaybe cookieName
acceptable <- getAcceptLanguage
- <&> filter ((> 0) . quality)
- <&> map mainType
+ <&> filter ((> 0) . (.quality))
+ <&> map (.mainType)
case preferred of
Nothing -> return ()
diff --git a/lib/Hikaru/Media.hs b/lib/Hikaru/Media.hs
index cc77e17..b8d3620 100644
--- a/lib/Hikaru/Media.hs
+++ b/lib/Hikaru/Media.hs
@@ -147,10 +147,10 @@ where
-- False
--
matchMedia :: Media -> Media -> Bool
- matchMedia l r = mainMatches && subMatches && quality r > 0.0
+ matchMedia l r = mainMatches && subMatches && r.quality > 0.0
where
- mainMatches = mainType l == mainType r || mainType r == "*"
- subMatches = subType l == subType r || subType r == "*"
+ mainMatches = l.mainType == r.mainType || r.mainType == "*"
+ subMatches = l.subType == r.subType || r.subType == "*"
-- |
@@ -176,9 +176,9 @@ where
selectMedia :: [Media] -> [Media] -> Maybe Media
selectMedia ls rs = case best of
[ ] -> Nothing
- (l, r):_ -> Just $ l { quality = quality r }
+ (l, r):_ -> Just $ l { quality = r.quality }
where
- best = sortOn (negate . quality . snd) good
+ best = sortOn (negate . (.quality) . snd) good
good = filter (uncurry matchMedia) prod
prod = [(l, r) | l <- ls, r <- rs]
diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs
index 6899bd4..cfd6b8d 100644
--- a/lib/Hikaru/Route.hs
+++ b/lib/Hikaru/Route.hs
@@ -221,9 +221,10 @@ where
-- dispatching or with 'routeScore'.
--
(/?) :: Route ts a -> Appraisal -> Route ts a
- (/?) r@Route{..} Appraisal{score = score', vary = vary'} =
- r { vary = nub (vary' <> vary)
- , score = score' : score
+ (/?) r a =
+ r { vary = nub (a.vary <> r.vary)
+ , score = a.score : r.score
+ , path = r.path
}
--
GitLab