Skip to content
Snippets Groups Projects
Verified Commit 70c4e1f5 authored by jan.hamal.dvorak's avatar jan.hamal.dvorak
Browse files

Merge FromParam with ToParam into Param 


Signed-off-by: default avatarJan Hamal Dvořák <mordae@anilinux.org>
parent fc7da17f
No related branches found
No related tags found
No related merge requests found
Show whitespace changes
Inline Side-by-side
hikaru.cabal
+ 2
− 2
View file @ 70c4e1f5
......@@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: c3d7457dca96378df357bb52bd4eb8bf006764d262483124af6a580c32a228b7
-- hash: 789872e5159353725050ec2764d9951be0fbf0c39bb684307f281650bb6fd9a8
name: hikaru
version: 0.1.0.0
......@@ -47,7 +47,7 @@ library
Paths_hikaru
hs-source-dirs:
lib
default-extensions: BlockArguments DefaultSignatures FlexibleInstances GeneralizedNewtypeDeriving GADTs LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving
default-extensions: BlockArguments DataKinds DefaultSignatures FlexibleInstances GADTs GeneralizedNewtypeDeriving KindSignatures LambdaCase MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving UndecidableInstances
ghc-options: -Wall -Wcompat
build-depends:
aeson >=1.4 && <1.5
......
lib/Hikaru/Action.hs
+ 15
− 15
View file @ 70c4e1f5
......@@ -99,6 +99,7 @@ where
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Lazy as LT
import qualified Network.Wai.Parse as Parse
import Control.Monad.Trans
import Control.Monad.Trans.Resource
......@@ -112,7 +113,6 @@ where
import Network.HTTP.Types.Method
import Network.HTTP.Types.Status
import Network.Wai
import Network.Wai.Parse
import Web.Cookie
import Hikaru.Media
import Hikaru.Types
......@@ -364,14 +364,14 @@ where
--
getParams :: (MonadAction m) => m [(Text, Text)]
getParams = map convert <$> queryString <$> getRequest
where convert (n, v) = (cs n, fromMaybe "" $ cs <$> v)
where convert (n, v) = (cs n, maybe "" cs v)
-- |
-- Obtain a specific request query string parameter and parse it
-- on the fly to the target type. Parsing failure maps to 'Nothing'.
--
getParamMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
getParamMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
getParamMaybe n = do
value <- lookup n <$> getParams
return $ fromParam =<< value
......@@ -381,7 +381,7 @@ where
-- Similar to 'getParamMaybe', but return either the parsed parameter
-- or the specified default value.
--
getParamDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
getParamDefault :: (MonadAction m, Param a) => Text -> a -> m a
getParamDefault n v = fromMaybe v <$> getParamMaybe n
......@@ -389,7 +389,7 @@ where
-- Obtain a group of request query string parameters with the same name
-- and parse them on the fly to the target type.
--
getParamList :: (MonadAction m, FromParam a) => Text -> m [a]
getParamList :: (MonadAction m, Param a) => Text -> m [a]
getParamList n = mapMaybe (fromParam . snd)
<$> filter ((n ==) . fst)
<$> getParams
......@@ -411,7 +411,7 @@ where
-- Obtain a specific cookie and parse it on the fly to the target type.
-- Parsing failure maps to 'Nothing'.
--
getCookieMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
getCookieMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
getCookieMaybe n = do
value <- lookup n <$> getCookies
return $ fromParam =<< value
......@@ -421,7 +421,7 @@ where
-- Similar to 'getCookieMaybe', but return either the parsed cookie
-- or the specified default value.
--
getCookieDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
getCookieDefault :: (MonadAction m, Param a) => Text -> a -> m a
getCookieDefault n v = fromMaybe v <$> getCookieMaybe n
......@@ -623,7 +623,7 @@ where
-- Obtain a specific form field and parse it on the fly to the target type.
-- Parsing failure maps to 'Nothing'.
--
getFieldMaybe :: (MonadAction m, FromParam a) => Text -> m (Maybe a)
getFieldMaybe :: (MonadAction m, Param a) => Text -> m (Maybe a)
getFieldMaybe n = do
value <- lookup n <$> getFields
return $ fromParam =<< value
......@@ -633,7 +633,7 @@ where
-- Similar to 'getFieldMaybe', but return either the parsed field
-- or the specified default value.
--
getFieldDefault :: (MonadAction m, FromParam a) => Text -> a -> m a
getFieldDefault :: (MonadAction m, Param a) => Text -> a -> m a
getFieldDefault n v = fromMaybe v <$> getFieldMaybe n
......@@ -641,7 +641,7 @@ where
-- Obtain a group of form fields with the same name and parse them on the
-- fly to the target type.
--
getFieldList :: (MonadAction m, FromParam a) => Text -> m [a]
getFieldList :: (MonadAction m, Param a) => Text -> m [a]
getFieldList n = mapMaybe (fromParam . snd)
<$> filter ((n ==) . fst)
<$> getFields
......@@ -691,7 +691,7 @@ where
-- Body has not been parsed yet. This is very good.
BodyUnparsed -> do
bodyType <- getRequestBodyType <$> getRequest
bodyType <- Parse.getRequestBodyType <$> getRequest
getChunk <- getBodyChunkIO
case bodyType of
......@@ -703,7 +703,7 @@ where
-- Parse the form data.
form' <- liftIO do
sinkRequestBody (tempFileBackEnd rtis) bt getChunk
Parse.sinkRequestBody (Parse.tempFileBackEnd rtis) bt getChunk
-- Perform string conversions and simplify uploaded file types.
let form = adaptForm form'
......@@ -720,12 +720,12 @@ where
-- |
-- Convert form names and fields from 'ByteString' to 'Text' and
-- extract just the uploaded file names from the 'FileInfo' structures.
-- extract just the uploaded file names from the 'Parse.FileInfo' structures.
--
adaptForm :: ([Param], [(ByteString, FileInfo FilePath)]) -> FormData
adaptForm :: ([Parse.Param], [(ByteString, Parse.FileInfo FilePath)]) -> FormData
adaptForm (ps, fs) = (map cs2 ps, map convFile fs)
where
convFile (n, FileInfo{fileContent}) = (cs n, fileContent)
convFile (n, Parse.FileInfo{fileContent}) = (cs n, fileContent)
-- |
......
lib/Hikaru/Form.hs
+ 15
− 15
View file @ 70c4e1f5
......@@ -170,7 +170,7 @@ where
{-# INLINE fmap #-}
instance (Monad m) => Applicative (Form l m) where
pure x = Form $ return $ Just x
pure x = Form $ pure $ Just x
{-# INLINE pure #-}
Form{unForm = unFormL} <*> Form{unForm = unFormR} = Form do
......@@ -286,7 +286,7 @@ where
-- |
-- TODO
--
hiddenField' :: (Monad m, ToParam a, FromParam a)
hiddenField' :: (Monad m, Param a)
=> Text -> FieldT l a m b -> Form l m a
hiddenField' name field = hiddenField name Nothing field
......@@ -294,7 +294,7 @@ where
-- |
-- TODO
--
hiddenField :: (Monad m, ToParam a, FromParam a)
hiddenField :: (Monad m, Param a)
=> Text -> Maybe a -> FieldT l a m b -> Form l m a
hiddenField name orig field = Form do
name' <- makeName name
......@@ -316,7 +316,7 @@ where
-- |
-- TODO
--
inputField' :: (Monad m, ToParam a, FromParam a)
inputField' :: (Monad m, Param a)
=> Text -> l -> FieldT l a m b -> Form l m a
inputField' name label field = inputField name label Nothing field
......@@ -324,7 +324,7 @@ where
-- |
-- TODO
--
inputField :: (Monad m, ToParam a, FromParam a)
inputField :: (Monad m, Param a)
=> Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
inputField name label orig field = Form do
name' <- makeName name
......@@ -347,7 +347,7 @@ where
-- |
-- TODO
--
textArea' :: (Monad m, ToParam a, FromParam a)
textArea' :: (Monad m, Param a)
=> Text -> l -> FieldT l a m b -> Form l m a
textArea' name label field = textArea name label Nothing field
......@@ -355,7 +355,7 @@ where
-- |
-- TODO
--
textArea :: (Monad m, ToParam a, FromParam a)
textArea :: (Monad m, Param a)
=> Text -> l -> Maybe a -> FieldT l a m b -> Form l m a
textArea name label orig field = Form do
name' <- makeName name
......@@ -378,7 +378,7 @@ where
-- |
-- TODO
--
selectField' :: (Monad m, ToParam a, FromParam a, Eq a)
selectField' :: (Monad m, Param a, Eq a)
=> Text -> l -> (a -> l) -> [a]
-> FieldT l a m b -> Form l m a
selectField' name label optlabel options field
......@@ -388,7 +388,7 @@ where
-- |
-- TODO
--
selectField :: (Monad m, ToParam a, FromParam a, Eq a)
selectField :: (Monad m, Param a, Eq a)
=> Text -> l -> (a -> l) -> [a] -> Maybe a
-> FieldT l a m b -> Form l m a
selectField name label optlabel options orig field = Form do
......@@ -414,7 +414,7 @@ where
-- |
-- TODO
--
selectFieldEnum' :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
selectFieldEnum' :: (Monad m, Param a, Eq a, Bounded a, Enum a)
=> Text -> l -> (a -> l) -> FieldT l a m b -> Form l m a
selectFieldEnum' name label optlabel field
= selectFieldEnum name label optlabel Nothing field
......@@ -425,7 +425,7 @@ where
--
-- TODO: Example
--
selectFieldEnum :: (Monad m, ToParam a, FromParam a, Eq a, Bounded a, Enum a)
selectFieldEnum :: (Monad m, Param a, Eq a, Bounded a, Enum a)
=> Text -> l -> (a -> l) -> Maybe a
-> FieldT l a m b -> Form l m a
selectFieldEnum name label optlabel orig field
......@@ -435,7 +435,7 @@ where
-- |
-- TODO
--
multiSelectField' :: (Monad m, ToParam a, FromParam a, Eq a)
multiSelectField' :: (Monad m, Param a, Eq a)
=> Text -> l -> (a -> l) -> [a]
-> FieldT l [a] m b -> Form l m [a]
multiSelectField' name label optlabel options field
......@@ -445,7 +445,7 @@ where
-- |
-- TODO
--
multiSelectField :: (Monad m, ToParam a, FromParam a, Eq a)
multiSelectField :: (Monad m, Param a, Eq a)
=> Text -> l -> (a -> l) -> [a] -> Maybe [a]
-> FieldT l [a] m b -> Form l m [a]
multiSelectField name label optlabel options orig field = Form do
......@@ -566,7 +566,7 @@ where
isErrorNote _else = False
formParamMaybe :: (Monad m, FromParam a) => Text -> FormT l m (Maybe a)
formParamMaybe :: (Monad m, Param a) => Text -> FormT l m (Maybe a)
formParamMaybe name = do
Env{envParams} <- ask
return $ fromParam =<< lookup name envParams
......@@ -578,7 +578,7 @@ where
return $ lookup name envFiles
formParams :: (Monad m, FromParam a) => Text -> FormT l m [a]
formParams :: (Monad m, Param a) => Text -> FormT l m [a]
formParams name = do
Env{envParams} <- ask
let match = (name ==) . fst
......
lib/Hikaru/Route.hs
+ 1
− 1
View file @ 70c4e1f5
......@@ -234,7 +234,7 @@ where
--
-- Fails with 'NotFound' if the segment is missing or unparseable.
--
arg :: (FromParam a) => Route a
arg :: (Param a) => Route a
arg = argWith fromParam
......
lib/Hikaru/Types.hs
+ 112
− 106
View file @ 70c4e1f5
......@@ -11,9 +11,9 @@ This module provides types common for multiple other modules.
-}
module Hikaru.Types
( FromParam(..)
, ToParam(..)
( Param(..)
, RequestError(..)
, Severity(..)
, defaultHandler
)
where
......@@ -37,192 +37,176 @@ where
-- parameter into some kind of value. One does not usually pass around
-- more complex arguments than these, so forgive the limited menu.
--
class FromParam a where
class Param a where
fromParam :: Text -> Maybe a
toParam :: a -> Text
instance FromParam Int where
fromParam = readMaybe . unpack
instance (Param a) => Param (Maybe a) where
fromParam = Just . fromParam
{-# INLINE fromParam #-}
instance FromParam Int8 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Int16 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = maybe "" toParam
{-# INLINE toParam #-}
instance FromParam Int32 where
instance Param Int where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Int64 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Word where
instance Param Int8 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Word8 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Word16 where
instance Param Int16 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Word32 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Word64 where
instance Param Int32 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Integer where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Natural where
instance Param Int64 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Float where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Double where
instance Param Word where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam () where
fromParam _ = Just ()
{-# INLINE fromParam #-}
instance FromParam Bool where
fromParam "true" = Just True
fromParam "True" = Just True
fromParam "false" = Just False
fromParam "False" = Just False
fromParam _else = Nothing
{-# INLINE fromParam #-}
instance FromParam Char where
fromParam inp = case (unpack inp) of
[x] -> Just x
_else -> Nothing
{-# INLINE fromParam #-}
instance FromParam Text where
fromParam = Just . id
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Data.Text.Lazy.Text where
fromParam = Just . Data.Text.Lazy.fromStrict
instance Param Word8 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance FromParam Data.ByteString.ByteString where
fromParam = Just . Data.Text.Encoding.encodeUtf8
{-# INLINE fromParam #-}
toParam = pack . show
{-# INLINE toParam #-}
instance FromParam Data.ByteString.Lazy.ByteString where
fromParam = Just . Data.ByteString.Lazy.fromStrict
. Data.Text.Encoding.encodeUtf8
instance Param Word16 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
-- |
-- Values that can be represented as a piece of 'Text' to be used in a
-- route segment or a query string. One does not usually pass around
-- more complex arguments than these, so forgive the limited menu.
--
class ToParam a where
toParam :: a -> Text
instance ToParam Int where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Int8 where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Word32 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Int16 where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Int32 where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Word64 where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Int64 where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Word where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Integer where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Word8 where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Word16 where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Natural where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Word32 where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Word64 where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Float where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Integer where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Natural where
toParam = pack . show
{-# INLINE toParam #-}
instance Param Double where
fromParam = readMaybe . unpack
{-# INLINE fromParam #-}
instance ToParam Float where
toParam = pack . show
{-# INLINE toParam #-}
instance ToParam Double where
toParam = pack . show
{-# INLINE toParam #-}
instance Param () where
fromParam _ = Just ()
{-# INLINE fromParam #-}
instance ToParam () where
toParam _ = ""
{-# INLINE toParam #-}
instance ToParam Bool where
instance Param Bool where
fromParam "true" = Just True
fromParam "True" = Just True
fromParam "on" = Just True
fromParam "On" = Just True
fromParam "1" = Just True
fromParam "false" = Just False
fromParam "False" = Just False
fromParam "off" = Just False
fromParam "Off" = Just False
fromParam "0" = Just False
fromParam _else = Nothing
{-# INLINE fromParam #-}
toParam True = "true"
toParam False = "false"
{-# INLINE toParam #-}
instance ToParam Char where
instance Param Char where
fromParam inp = case (unpack inp) of
[x] -> Just x
_else -> Nothing
{-# INLINE fromParam #-}
toParam char = pack [char]
{-# INLINE toParam #-}
instance ToParam Text where
instance Param Text where
fromParam = Just . id
{-# INLINE fromParam #-}
toParam = id
{-# INLINE toParam #-}
instance ToParam Data.Text.Lazy.Text where
instance Param Data.Text.Lazy.Text where
fromParam = Just . Data.Text.Lazy.fromStrict
{-# INLINE fromParam #-}
toParam = Data.Text.Lazy.toStrict
{-# INLINE toParam #-}
instance ToParam Data.ByteString.ByteString where
instance Param Data.ByteString.ByteString where
fromParam = Just . Data.Text.Encoding.encodeUtf8
{-# INLINE fromParam #-}
toParam = Data.Text.Encoding.decodeUtf8With
Data.Text.Encoding.Error.lenientDecode
{-# INLINE toParam #-}
instance ToParam Data.ByteString.Lazy.ByteString where
instance Param Data.ByteString.Lazy.ByteString where
fromParam = Just . Data.ByteString.Lazy.fromStrict
. Data.Text.Encoding.encodeUtf8
{-# INLINE fromParam #-}
toParam = Data.Text.Encoding.decodeUtf8With
Data.Text.Encoding.Error.lenientDecode
. Data.ByteString.Lazy.toStrict
......@@ -327,4 +311,26 @@ where
. cs . (<> "\n" <> msg)
-- |
-- Information severity to be used for messages.
--
data Severity
= Success
| Warning
| Danger
deriving (Eq, Ord, Enum, Show)
-- |
-- Concatenation yields the higher severity.
--
instance Semigroup Severity where
(<>) = max
-- |
-- 'Success' is the neutral element.
--
instance Monoid Severity where
mempty = Success
-- vim:set ft=haskell sw=2 ts=2 et:
package.yaml
+ 4
− 1
View file @ 70c4e1f5
......@@ -24,10 +24,12 @@ extra-source-files: README.md
ghc-options: -Wall -Wcompat
default-extensions:
- BlockArguments
- DataKinds
- DefaultSignatures
- FlexibleInstances
- GeneralizedNewtypeDeriving
- GADTs
- GeneralizedNewtypeDeriving
- KindSignatures
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
......@@ -37,6 +39,7 @@ default-extensions:
- RecordWildCards
- ScopedTypeVariables
- StandaloneDeriving
- UndecidableInstances
dependencies:
- aeson >= 1.4 && <1.5
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment

Pirátský GitLab - Home of the CopyLeft