ToQueryData, FromQueryData

example/Example/Colors.hs

@@ -1,8 +1,5 @@
 module Example.Colors where
 
-import Data.String.Conversions
-import Text.Read (readMaybe)
-import Web.HttpApiData
 import Web.Hyperbole
 
 data AppColor
@@ -19,15 +16,7 @@ data AppColor
   | PrimaryLight
   | Secondary
   | SecondaryLight
-  deriving (Show, Read)
-
-instance ToHttpApiData AppColor where
-  toQueryParam c = cs (show c)
-instance FromHttpApiData AppColor where
-  parseQueryParam t = do
-    case readMaybe (cs t) of
-      Nothing -> Left $ "Invalid AppColor: " <> t
-      (Just c) -> pure c
+  deriving (Show, Read, ToQueryData, FromQueryData)
 
 instance ToColor AppColor where
   colorValue White = "#FFF"

example/Example/Effects/Todos.hs

@@ -7,9 +7,7 @@ import Data.Text (Text, pack)
 import Effectful
 import Effectful.Dispatch.Dynamic
 import System.Random (randomRIO)
-import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))
-import Web.Hyperbole (Hyperbole, clearSession, session, setSession)
-import Web.Hyperbole.Effect.Session (readQueryParam, showQueryParam)
+import Web.Hyperbole (FromQueryData (..), Hyperbole, ToQueryData (..), clearSession, session, setSession)
 
 type TodoId = Text
 
@@ -18,62 +16,45 @@ data Todo = Todo
   , task :: Text
   , completed :: Bool
   }
-  deriving (Show, Read)
+  deriving (Show, Read, ToQueryData, FromQueryData)
 
-newtype TodoIds = TodoIds [Text]
-  deriving newtype (Show, Read, Monoid, Semigroup)
-
--- We need an instance of From/To HttpApiData to save to a session
-instance FromHttpApiData Todo where
-  parseQueryParam = readQueryParam
-instance ToHttpApiData Todo where
-  toQueryParam = showQueryParam
-
--- there's no list instance for some reason
-instance FromHttpApiData TodoIds where
-  parseQueryParam = readQueryParam
-instance ToHttpApiData TodoIds where
-  toQueryParam = showQueryParam
-
--- Load a user AND do next if missing?
 data Todos :: Effect where
   LoadAll :: Todos m [Todo]
   Save :: Todo -> Todos m ()
   Remove :: TodoId -> Todos m ()
   Create :: Text -> Todos m TodoId
 type instance DispatchOf Todos = 'Dynamic
-
 runTodosSession
   :: forall es a
    . (Hyperbole :> es, IOE :> es)
   => Eff (Todos : es) a
   -> Eff es a
 runTodosSession = interpret $ \_ -> \case
   LoadAll -> do
-    TodoIds ids <- sessionTodoIds
+    ids <- sessionTodoIds
     catMaybes <$> mapM session ids
   Save todo -> do
     setSession todo.id todo
   Remove todoId -> do
-    TodoIds ids <- sessionTodoIds
-    sessionSaveTodoIds $ TodoIds $ filter (/= todoId) ids
+    ids <- sessionTodoIds
+    sessionSaveTodoIds $ filter (/= todoId) ids
     clearSession todoId
   Create task -> do
     todoId <- randomId
     let todo = Todo todoId task False
-    TodoIds ids <- sessionTodoIds
+    ids <- sessionTodoIds
     setSession todo.id todo
-    sessionSaveTodoIds $ TodoIds (todo.id : ids)
+    sessionSaveTodoIds (todo.id : ids)
     pure todoId
  where
   randomId :: (IOE :> es) => Eff es Text
   randomId = pack . show <$> randomRIO @Int (0, 9999999)
 
-  sessionTodoIds :: (Hyperbole :> es) => Eff es TodoIds
+  sessionTodoIds :: (Hyperbole :> es) => Eff es [TodoId]
   sessionTodoIds = do
     fromMaybe mempty <$> session "todoIds"
 
-  sessionSaveTodoIds :: (Hyperbole :> es) => TodoIds -> Eff es ()
+  sessionSaveTodoIds :: (Hyperbole :> es) => [TodoId] -> Eff es ()
   sessionSaveTodoIds = setSession "todoIds"
 
 loadAll :: (Todos :> es) => Eff es [Todo]

example/Example/Forms.hs

@@ -33,7 +33,7 @@ instance HyperView FormView es where
 -- Form Fields
 newtype User = User {username :: Text}
   deriving (Generic)
-  deriving newtype (FromHttpApiData)
+  deriving newtype (FromQueryData)
 
 data UserForm f = UserForm
   { user :: Field f User

example/Example/Todo.hs

@@ -94,7 +94,7 @@ todoForm filt = do
   row (border 1) $ do
     el (pad 8) $ do
       button (ToggleAll filt) (width 32 . hover (color Primary)) Icon.chevronDown
-    form @TodoForm SubmitTodo id $ do
+    form @TodoForm SubmitTodo grow $ do
       field f.task (const id) $ do
         input TextInput (pad 12 . placeholder "What needs to be done?")
 

example/hyperbole-examples.cabal

@@ -57,6 +57,7 @@ executable docgen
     , string-conversions
     , string-interpolate
     , text
+    , time
     , wai
     , wai-websockets
     , warp
@@ -72,6 +73,7 @@ executable examples
       Web.Hyperbole.Effect.Event
       Web.Hyperbole.Effect.Handler
       Web.Hyperbole.Effect.Hyperbole
+      Web.Hyperbole.Effect.QueryData
       Web.Hyperbole.Effect.Request
       Web.Hyperbole.Effect.Respond
       Web.Hyperbole.Effect.Server
@@ -153,6 +155,7 @@ executable examples
     , string-conversions
     , string-interpolate
     , text
+    , time
     , wai
     , wai-middleware-static
     , wai-websockets

example/package.yaml

@@ -33,6 +33,7 @@ dependencies:
   - casing
   - effectful
   - text
+  - time
   - string-interpolate
   - file-embed
   - http-api-data

hyperbole.cabal

@@ -36,6 +36,7 @@ library
       Web.Hyperbole.Effect.Event
       Web.Hyperbole.Effect.Handler
       Web.Hyperbole.Effect.Hyperbole
+      Web.Hyperbole.Effect.QueryData
       Web.Hyperbole.Effect.Request
       Web.Hyperbole.Effect.Respond
       Web.Hyperbole.Effect.Server
@@ -79,6 +80,7 @@ library
     , string-conversions ==0.4.*
     , string-interpolate ==0.3.*
     , text >=1.2 && <3
+    , time
     , wai >=3.2 && <4
     , wai-websockets >=3.0 && <4
     , warp >=3.3 && <4
@@ -90,6 +92,7 @@ test-suite test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      Test.FormSpec
       Test.RouteSpec
       Test.ViewActionSpec
       Test.ViewIdSpec
@@ -127,6 +130,7 @@ test-suite test
     , string-conversions ==0.4.*
     , string-interpolate ==0.3.*
     , text >=1.2 && <3
+    , time
     , wai >=3.2 && <4
     , wai-websockets >=3.0 && <4
     , warp >=3.3 && <4

package.yaml

@@ -44,6 +44,7 @@ dependencies:
   - casing > 0.1 && <0.2
   - effectful >= 2.4 && <3
   - text >= 1.2 && <3
+  - time
   - string-interpolate >= 0.3 && <0.4
   - file-embed >= 0.0.10 && <0.1
   - http-api-data >= 0.6 && <0.7

src/Web/Hyperbole.hs

@@ -72,7 +72,8 @@ module Web.Hyperbole
   , hasParam
   , formBody
   , formData
-  , FromHttpApiData
+  , ToQueryData (..)
+  , FromQueryData (..)
 
     -- ** Response
   , notFound
@@ -171,6 +172,7 @@ import Network.Wai (Application)
 import Network.Wai.Handler.Warp as Warp (run)
 import Web.Hyperbole.Application
 import Web.Hyperbole.Effect.Hyperbole
+import Web.Hyperbole.Effect.QueryData (FromQueryData (..), ToQueryData (..))
 import Web.Hyperbole.Effect.Request (formBody, hasParam, lookupParam, reqParam, reqParams, request)
 import Web.Hyperbole.Effect.Respond (notFound, redirect, respondEarly, view)
 import Web.Hyperbole.Effect.Server

src/Web/Hyperbole/Effect/Hyperbole.hs

@@ -8,7 +8,7 @@ import Effectful
 import Effectful.Dispatch.Dynamic
 import Effectful.Error.Static
 import Effectful.State.Static.Local
-import Web.HttpApiData (FromHttpApiData, ToHttpApiData (..))
+import Web.Hyperbole.Effect.QueryData
 import Web.Hyperbole.Effect.Server
 import Web.Hyperbole.Effect.Session as Session
 
@@ -70,14 +70,14 @@ data HyperState = HyperState
 
 
 -- | Lookup a session variable by keyword
-session :: (FromHttpApiData a, Hyperbole :> es) => Text -> Eff es (Maybe a)
+session :: (FromQueryData a, Hyperbole :> es) => Text -> Eff es (Maybe a)
 session k = do
   s <- send GetSession
   pure $ sessionLookup k s
 
 
 -- | Set a session variable by keyword
-setSession :: (ToHttpApiData a, Hyperbole :> es) => Text -> a -> Eff es ()
+setSession :: (ToQueryData a, Hyperbole :> es) => Text -> a -> Eff es ()
 setSession k v = do
   send $ ModSession (sessionSet k v)
 

src/Web/Hyperbole/Effect/QueryData.hs

@@ -0,0 +1,146 @@
+{-# LANGUAGE DefaultSignatures #-}
+
+module Web.Hyperbole.Effect.QueryData where
+
+import Data.Text (Text, pack)
+import Data.Time (UTCTime)
+import Data.Word
+import Text.Read (readMaybe)
+import Web.HttpApiData
+
+
+-- | Reimplement 'ToHttpApiData' based on Show
+class ToQueryData a where
+  toQueryData :: a -> Text
+  default toQueryData :: (Show a) => a -> Text
+  toQueryData = showQueryParam
+
+
+-- | Reimplement 'FromHttpApiData' based on Read
+class FromQueryData a where
+  parseQueryData :: Text -> Either Text a
+  default parseQueryData :: (Read a) => Text -> Either Text a
+  parseQueryData = readQueryParam
+
+
+instance ToQueryData Int where
+  toQueryData = toQueryParam
+instance FromQueryData Int where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Integer where
+  toQueryData = toQueryParam
+instance FromQueryData Integer where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Float where
+  toQueryData = toQueryParam
+instance FromQueryData Float where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Double where
+  toQueryData = toQueryParam
+instance FromQueryData Double where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Word where
+  toQueryData = toQueryParam
+instance FromQueryData Word where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Word8 where
+  toQueryData = toQueryParam
+instance FromQueryData Word8 where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Word16 where
+  toQueryData = toQueryParam
+instance FromQueryData Word16 where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Word32 where
+  toQueryData = toQueryParam
+instance FromQueryData Word32 where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Word64 where
+  toQueryData = toQueryParam
+instance FromQueryData Word64 where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Bool where
+  toQueryData = toQueryParam
+instance FromQueryData Bool where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Text where
+  toQueryData = toQueryParam
+instance FromQueryData Text where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData Char where
+  toQueryData = toQueryParam
+instance FromQueryData Char where
+  parseQueryData = parseQueryParam
+
+
+instance ToQueryData UTCTime where
+  toQueryData = toQueryParam
+instance FromQueryData UTCTime where
+  parseQueryData = parseQueryParam
+
+
+instance (Show a) => ToQueryData [a] where
+  toQueryData = showQueryParam
+instance (Read a) => FromQueryData [a] where
+  parseQueryData = readQueryParam
+
+
+instance (ToQueryData a) => ToQueryData (Maybe a) where
+  toQueryData Nothing = ""
+  toQueryData (Just a) = toQueryData a
+instance (Read a) => FromQueryData (Maybe a) where
+  parseQueryData "" = pure Nothing
+  parseQueryData t = readQueryParam t
+
+
+instance (ToQueryData a, ToQueryData b) => ToQueryData (Either a b) where
+  toQueryData (Left a) = toQueryData a
+  toQueryData (Right b) = toQueryData b
+instance (FromQueryData a, FromQueryData b) => FromQueryData (Either a b) where
+  parseQueryData t =
+    case parseQueryData @a t of
+      Right a -> pure $ Left a
+      Left _ -> do
+        case parseQueryData @b t of
+          Left _ -> Left $ "Could not parseQueryData Either: " <> t
+          Right b -> pure $ Right b
+
+
+-- | Encode a Show as a query param
+showQueryParam :: (Show a) => a -> Text
+showQueryParam a = toQueryParam $ show a
+
+
+-- | Decode a Read as a query param
+readQueryParam :: (Read a) => Text -> Either Text a
+readQueryParam t = do
+  str <- parseQueryParam t
+  case readMaybe str of
+    Nothing -> Left $ pack $ "Could not read query param: " <> str
+    Just a -> pure a
+
+
+parseQueryDatas :: (Traversable t, FromQueryData a) => t Text -> Either Text (t a)
+parseQueryDatas = traverse parseQueryData