diff --git a/hikaru.cabal b/hikaru.cabal index 91bdd2cb3b5a997ed0d860c6e04fb5b13a7ac86d..13ef444d54fa11c85cd5fc7756fb74d2b7ee8834 100644 --- a/hikaru.cabal +++ b/hikaru.cabal @@ -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 diff --git a/lib/Hikaru/Action.hs b/lib/Hikaru/Action.hs index b6549a54a2992af4c9289ff3fcaf332036147d4c..37791519339a6a2b19c4e6efb8f9d81c8ad6dc96 100644 --- a/lib/Hikaru/Action.hs +++ b/lib/Hikaru/Action.hs @@ -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) -- | diff --git a/lib/Hikaru/Form.hs b/lib/Hikaru/Form.hs index 2be433b7048060484726f95b01bf65f416b7baa6..d255e9fea1367f7f1810a479d0744f1f43997e2d 100644 --- a/lib/Hikaru/Form.hs +++ b/lib/Hikaru/Form.hs @@ -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 diff --git a/lib/Hikaru/Route.hs b/lib/Hikaru/Route.hs index a2ddc39d1ac680c52e89925a5b42ca4462007ec1..be6b572515e75f790c8ce1d39257c0ec43188430 100644 --- a/lib/Hikaru/Route.hs +++ b/lib/Hikaru/Route.hs @@ -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 diff --git a/lib/Hikaru/Types.hs b/lib/Hikaru/Types.hs index 7f26f1287b6a954935896f0a63409894a5f8cbb2..4d37016584d43ab2be60d4f4947019fc0ab3c225 100644 --- a/lib/Hikaru/Types.hs +++ b/lib/Hikaru/Types.hs @@ -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: diff --git a/package.yaml b/package.yaml index 57c6ddf7d5d92a2eae0d3ca8ff1137130606a438..b78b5ab9956088cb8553cc1b420e856d997408d3 100644 --- a/package.yaml +++ b/package.yaml @@ -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