Convert.hs

{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Custom fpco conversion of Haskell values to a JSON Fay value.

module FP.API.Convert
  (encodeFpco
  ,decodeFpco
  ,validFileName
  ,validateFilePath)
  where

import           Control.Monad
import           Data.Aeson
import           Data.Aeson.Types (parseEither)
import           Data.ByteString        (ByteString)
import qualified Data.ByteString.Char8  as BS
import           Data.Data
import           Data.Generics.Aliases
import qualified Data.Text              as Text
import           Fay.Convert (encodeFay, decodeFay)
import qualified FP.API                 as API
import           FP.API.ModuleName
import           Prelude

encodeFpco :: GenericQ Value
encodeFpco = encodeFay $ \f -> (f
    `extQ` (int :: Integer -> Value))
  where
    int = Number . fromIntegral

{-
$ \f -> f
   `extQ` bytestring
   `extQ` int64
  where
    obj con = Object . Map.fromList . (("instance", String con):)
    wrapper con field val = obj con [(field, val)]
    bytestring = wrapper "ByteString" "slot1" . String . decodeUtf8 . B64.encode
    int64 :: Int64 -> Value
    int64 = wrapper "Int64" "slot1" . String . Text.pack . show
-}

decodeFpco :: Data a => Value -> Either String a
decodeFpco = decodeFay $ \value r -> r
   `extR` parseInteger value
   `extR` (validateEncFileName =<< normalDecode value)
   `extR` (either (Left . Text.unpack) Right . checkModuleName =<< normalDecode value)

normalDecode :: Data a => Value -> Either String a
normalDecode = decodeFay (\_ r' -> r')

{-
$ \value r -> r
   `extR` bytestring value
   `extR` int64 value
  where
    wrapper con field (Object mp)
      | Map.lookup "instance" mp == Just (String con)
      , Just val <- Map.lookup field mp
      = Right val
    wrapper con field val = Left $
      "Couldn't find expected " ++
      Text.unpack con ++ " constructor with " ++
      Text.unpack field ++ " field.  Instead, got\n" ++
      show val
    bytestring = B64.decode <=< fmap encodeUtf8 . expectText <=< wrapper "ByteString" "slot1"
    int64 :: Value -> Either String Int64
    int64 = expectRead <=< wrapper "Int64" "slot1"

expectText :: Value -> Either String Text
expectText (String txt) = Right txt
expectText val = Left $ "Expected string, but got " ++ show val

expectRead :: forall a. (Read a, Typeable a) => Value -> Either String a
expectRead val = maybe (Left err) Right . readMay . Text.unpack =<< expectText val
  where
    err = "Couldn't parse " ++ show (typeOf (undefined :: a)) ++ ", got: " ++ show val
-}

validateEncFileName :: API.EncFileName -> Either String API.EncFileName
validateEncFileName
    = fmap API.encFileNameFromByteString
    . validateFilePath
    . API.unFileName
    . API.unEncFileName

-- | Cannonicalizes and validates filepaths. See #1643.
validateFilePath :: ByteString -> Either String ByteString
validateFilePath path =
    case filter (not . BS.null) $ BS.splitWith (`elem` ['\\', '/']) $ BS.filter (/= '\NUL') path of
        [] -> Left "Invalid filepath: Empty"
        components -> Right $ BS.intercalate "/" components

validFileName :: ByteString -> Either String API.FileName
validFileName = fmap API.FileName . validateFilePath

-- |

-- Utilities copied from Fay.Convert

-- | Parse an int.
parseInteger :: Value -> Either String Integer
parseInteger = parseEither parseJSON