@@ -13,6 +13,7 @@
1313{-# LANGUAGE RankNTypes #-}
1414{-# LANGUAGE ScopedTypeVariables #-}
1515{-# LANGUAGE TemplateHaskell #-}
16+{-# LANGUAGE TypeApplications #-}
1617{-# LANGUAGE TypeFamilies #-}
1718{-# LANGUAGE TypeOperators #-}
1819{-# LANGUAGE ViewPatterns #-}
@@ -85,6 +86,11 @@ module Obelisk.Route
8586 , readShowEncoder
8687 , integralEncoder
8788 , pathSegmentEncoder
89+ , queryOnlyEncoder
90+ , Decoder(..)
91+ , dmapEncoder
92+ , fieldMapEncoder
93+ , jsonEncoder
8894 ) where
8995
9096import Prelude hiding ((.), id)
@@ -97,6 +103,7 @@ import Control.Category.Associative
97103import Control.Category.Monoidal
98104import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))
99105import Control.Monad.Except
106+import qualified Data.ByteString.Lazy as BSL
100107import Data.Dependent.Sum (DSum (..))
101108import Data.Dependent.Map (DMap)
102109import qualified Data.Dependent.Map as DMap
@@ -123,6 +130,9 @@ import Network.HTTP.Types.URI
123130import qualified Numeric.Lens
124131import Obelisk.Route.TH
125132import Text.Read (readMaybe)
133+import Data.Tabulation
134+import qualified Data.Aeson as Aeson
135+import Data.Aeson (FromJSON, ToJSON)
126136
127137-- Design goals:
128138-- No start-up time on the frontend (not yet met)
@@ -342,7 +352,7 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
342352justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
343353justEncoder = prismEncoder _Just
344354
345−-- |
355+-- | Encode () to 'Nothing'.
346356nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
347357nothingEncoder = prismEncoder _Nothing
348358
@@ -546,13 +556,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
546556 }
547557
548558pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
549−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
550− { _encoderImpl_decode = \(path, query) ->
551− if query == mempty
552− then pure path
553− else throwError "pathOnlyEncoderImpl: query was provided"
554− , _encoderImpl_encode = \path -> (path, mempty)
555− }
559+pathOnlyEncoder = second (unitEncoder mempty) . coidr
560+
561+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
562+queryOnlyEncoder = first (unitEncoder []) . coidl
556563
557564singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
558565singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -867,7 +874,6 @@ renderObeliskRoute e r =
867874readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
868875readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
869876
870−
871877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
872878integralEncoder = prismEncoder (Numeric.Lens.integral)
873879
@@ -880,4 +886,72 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl
880886 (x:xs) -> pure (x, (xs, y))
881887 }
882888
889+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
890+
891+dmapEncoder :: forall check parse k k' v.
892+ ( Monad check
893+ , MonadError Text parse
894+ , Universe (Some k')
895+ , Ord k
896+ , GCompare k'
897+ , GShow k'
898+ )
899+ => Encoder check parse (Some k') k
900+ -> (forall v'. k' v' -> Encoder check parse v' v)
901+ -> Encoder check parse (DMap k' Identity) (Map k v)
902+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
903+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
904+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some.This (k' :: k' t)) -> do
905+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
906+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
907+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
908+ return $ EncoderImpl
909+ { _encoderImpl_encode = \dm -> Map.fromList $ do
910+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
911+ return ( encode keyEncoder (Some.This k')
912+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
913+ )
914+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
915+ Some.This (k' :: k' t) <- tryDecode keyEncoder k
916+ case DMap.lookup k' valueDecoders of
917+ Nothing -> throwError . T.pack . keyError $ gshow k'
918+ Just (Decoder e) -> do
919+ v' <- tryDecode e v
920+ return (k' :=> Identity v')
921+ }
922+
923+fieldMapEncoder :: forall check parse r.
924+ ( Applicative check
925+ , MonadError Text parse
926+ , HasFields r
927+ , Universe (Some (Field r))
928+ , GShow (Field r)
929+ , GCompare (Field r)
930+ )
931+ => Encoder check parse r (DMap (Field r) Identity)
932+fieldMapEncoder = unsafeEncoder $ do
933+ pure $ EncoderImpl
934+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some.This f <- universe ]
935+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
936+ case DMap.lookup f dm of
937+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
938+ Just (Identity v) -> return v
939+ }
940+
941+-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
942+jsonEncoder :: forall check parse r.
943+ ( ToJSON r
944+ , FromJSON r
945+ , Applicative check
946+ , MonadError Text parse
947+ )
948+ => Encoder check parse r Text
949+jsonEncoder = unsafeEncoder $ do
950+ pure $ EncoderImpl
951+ { _encoderImpl_encode = \r -> decodeUtf8 . BSL.toStrict $ Aeson.encode r
952+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ encodeUtf8 t of
953+ Left err -> throwError ("jsonEncoder: " <> T.pack err)
954+ Right x -> return x
955+ }
956+
883957--TODO: decodeURIComponent as appropriate