@@ -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
@@ -124,6 +131,9 @@ import Network.HTTP.Types.URI
124131import qualified Numeric.Lens
125132import Obelisk.Route.TH
126133import Text.Read (readMaybe)
134+import Data.Tabulation
135+import qualified Data.Aeson as Aeson
136+import Data.Aeson (FromJSON, ToJSON)
127137
128138-- Design goals:
129139-- No start-up time on the frontend (not yet met)
@@ -343,7 +353,7 @@ maybeEncoder f g = shadowEncoder f g . maybeToEitherEncoder
343353justEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a (Maybe a)
344354justEncoder = prismEncoder _Just
345355
346−-- |
356+-- | Encode () to 'Nothing'.
347357nothingEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse () (Maybe a)
348358nothingEncoder = prismEncoder _Nothing
349359
@@ -547,13 +557,10 @@ pathOnlyEncoderIgnoringQuery = unsafeMkEncoder $ EncoderImpl
547557 }
548558
549559pathOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse [Text] PageName
550−pathOnlyEncoder = unsafeMkEncoder $ EncoderImpl
551− { _encoderImpl_decode = \(path, query) ->
552− if query == mempty
553− then pure path
554− else throwError "pathOnlyEncoderImpl: query was provided"
555− , _encoderImpl_encode = \path -> (path, mempty)
556− }
560+pathOnlyEncoder = second (unitEncoder mempty) . coidr
561+
562+queryOnlyEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Map Text (Maybe Text)) PageName
563+queryOnlyEncoder = first (unitEncoder []) . coidl
557564
558565singletonListEncoder :: (Applicative check, MonadError Text parse) => Encoder check parse a [a]
559566singletonListEncoder = unsafeMkEncoder $ EncoderImpl
@@ -866,7 +873,6 @@ renderObeliskRoute e r =
866873readShowEncoder :: (MonadError Text parse, Read a, Show a, Applicative check) => Encoder check parse a PageName
867874readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder
868875
869−
870876integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer
871877integralEncoder = prismEncoder (Numeric.Lens.integral)
872878
@@ -879,4 +885,72 @@ pathSegmentEncoder = unsafeMkEncoder EncoderImpl
879885 (x:xs) -> pure (x, (xs, y))
880886 }
881887
888+newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }
889+
890+dmapEncoder :: forall check parse k k' v.
891+ ( Monad check
892+ , MonadError Text parse
893+ , Universe (Some k')
894+ , Ord k
895+ , GCompare k'
896+ , GShow k'
897+ )
898+ => Encoder check parse (Some k') k
899+ -> (forall v'. k' v' -> Encoder check parse v' v)
900+ -> Encoder check parse (DMap k' Identity) (Map k v)
901+dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do
902+ keyEncoder :: Encoder Identity parse (Some k') k <- checkEncoder keyEncoder'
903+ valueDecoders :: DMap k' (Decoder Identity parse v) <- fmap DMap.fromList . forM universe $ \(Some.This (k' :: k' t)) -> do
904+ ve :: Encoder Identity parse t v <- checkEncoder (valueEncoderFor k')
905+ return $ (k' :: k' t) :=> (Decoder ve :: Decoder Identity parse v t)
906+ let keyError k = "dmapEncoder: key `" <> k <> "' was missing from the Universe instance for its type."
907+ return $ EncoderImpl
908+ { _encoderImpl_encode = \dm -> Map.fromList $ do
909+ ((k' :: k' t) :=> Identity v') <- DMap.toList dm
910+ return ( encode keyEncoder (Some.This k')
911+ , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'
912+ )
913+ , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do
914+ Some.This (k' :: k' t) <- tryDecode keyEncoder k
915+ case DMap.lookup k' valueDecoders of
916+ Nothing -> throwError . T.pack . keyError $ gshow k'
917+ Just (Decoder e) -> do
918+ v' <- tryDecode e v
919+ return (k' :=> Identity v')
920+ }
921+
922+fieldMapEncoder :: forall check parse r.
923+ ( Applicative check
924+ , MonadError Text parse
925+ , HasFields r
926+ , Universe (Some (Field r))
927+ , GShow (Field r)
928+ , GCompare (Field r)
929+ )
930+ => Encoder check parse r (DMap (Field r) Identity)
931+fieldMapEncoder = unsafeEncoder $ do
932+ pure $ EncoderImpl
933+ { _encoderImpl_encode = \r -> DMap.fromList [ f :=> Identity (indexField r f) | Some.This f <- universe ]
934+ , _encoderImpl_decode = \dm -> tabulateFieldsA $ \f -> do
935+ case DMap.lookup f dm of
936+ Nothing -> throwError $ "fieldMapEncoder: Couldn't find key for `" <> T.pack (gshow f) <> "' in DMap."
937+ Just (Identity v) -> return v
938+ }
939+
940+-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.
941+jsonEncoder :: forall check parse r.
942+ ( ToJSON r
943+ , FromJSON r
944+ , Applicative check
945+ , MonadError Text parse
946+ )
947+ => Encoder check parse r Text
948+jsonEncoder = unsafeEncoder $ do
949+ pure $ EncoderImpl
950+ { _encoderImpl_encode = \r -> decodeUtf8 . BSL.toStrict $ Aeson.encode r
951+ , _encoderImpl_decode = \t -> case Aeson.eitherDecodeStrict $ encodeUtf8 t of
952+ Left err -> throwError ("jsonEncoder: " <> T.pack err)
953+ Right x -> return x
954+ }
955+
882956--TODO: decodeURIComponent as appropriate