diff --git a/fpco-api.cabal b/fpco-api.cabal --- a/fpco-api.cabal +++ b/fpco-api.cabal @@ -1,5 +1,5 @@ name: fpco-api -version: 1.2.0.2 +version: 1.2.0.3 synopsis: Simple interface to the FP Complete IDE API. description: A server and library for communicating with the FP Complete IDE API. homepage: https://www.fpcomplete.com/page/api @@ -25,6 +25,7 @@ exposed-modules: FP.API , FP.API.Common + , FP.API.Convert , FP.API.ModuleName , FP.API.Runner , FP.API.Signal @@ -36,6 +37,7 @@ other-modules: FFI , FP.API.Dispatch + , Language.Fay.Yesod build-depends: base >=4 && < 5 , aeson >= 0.6 @@ -83,7 +85,6 @@ , unordered-containers >= 0.2 , vector >= 0.10 , yesod-core >= 1.2 - , yesod-fay >= 0.4 executable fpco-api if flag(jenkins-build) diff --git a/src/library/FP/API/Common.hs b/src/library/FP/API/Common.hs --- a/src/library/FP/API/Common.hs +++ b/src/library/FP/API/Common.hs @@ -39,7 +39,7 @@ import FP.API as API import FP.API.Dispatch import FP.API.Signal -import Fay.Convert +import FP.API.Convert import Language.Fay.Yesod (Returns(..)) import Prelude hiding (FilePath) @@ -258,7 +258,7 @@ Nothing -> clientFail $ "Call timed out: " <> T.pack shownCmd Just (Left err) -> return $ Left err Just (Right val) -> - case readFromFay' val of + case decodeFpco val of Left err -> clientFail $ "Failed to parse response to " <> T.pack shownCmd <> ": " <> T.pack err Right (Success x) -> do didRestart <- liftIO $ atomically $ updateSessionCompileId ciCompileId ciSessionId x @@ -338,7 +338,7 @@ "Could not parse JSON of response to " <> shownCmd <> ". Here's the response: " <> decodeUtf8 (BS.concat (LBS.toChunks body)) Just json -> - case readFromFay' json of + case decodeFpco json of Left err -> clientFail $ "Error interpreting response from " <> shownCmd <> ". Here's the error: " <> T.pack err diff --git a/src/library/FP/API/Convert.hs b/src/library/FP/API/Convert.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Convert.hs @@ -0,0 +1,104 @@ +{-# 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 diff --git a/src/library/FP/Server.hs b/src/library/FP/Server.hs --- a/src/library/FP/Server.hs +++ b/src/library/FP/Server.hs @@ -16,6 +16,7 @@ import FP.API import FP.API.Common +import FP.API.Convert import FP.API.Signal import FP.Server.Spans import FP.Server.Types @@ -42,7 +43,6 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.IO as T -import Fay.Convert import Language.Fay.Yesod (Returns(..)) import Network import Network.HTTP.Conduit @@ -445,7 +445,7 @@ ,("authorization",encodeUtf8 ("token " <> ccToken))] , responseTimeout = Nothing , cookieJar = Just jar - , requestBody = RequestBodyLBS $ encode (showToFay cmd) + , requestBody = RequestBodyLBS $ encode (encodeFpco cmd) , checkStatus = \_ _ _ -> Nothing } $(logDebug) ("=> " <> trunc (T.pack (show cmd))) diff --git a/src/library/Language/Fay/Yesod.hs b/src/library/Language/Fay/Yesod.hs new file mode 100644 --- /dev/null +++ b/src/library/Language/Fay/Yesod.hs @@ -0,0 +1,74 @@ +-- NOTE: This file is auto-generated. +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +-- | Module to be shared between server and client. +-- +-- This module must be valid for both GHC and Fay. +module Language.Fay.Yesod where + +import Prelude +#ifdef FAY +import FFI +#else +import Fay.FFI +#endif +import Data.Data + +#ifdef FAY + +data Text = Text + deriving (Show, Read, Eq, Typeable, Data) + +fromString :: String -> Text +fromString = ffi "%1" + +toString :: Text -> String +toString = ffi "%1" + +#else + +import qualified Data.Text as T + +type Text = T.Text + +fromString :: String -> Text +fromString = T.pack + +toString :: Text -> String +toString = T.unpack + +#endif + +-- | A proxy type for specifying what type a command should return. The final +-- field for each data constructor in a command datatype should be @Returns@. +data Returns a = Returns + deriving (Eq, Show, Read, Data, Typeable) + +-- | Call a command. +call :: (Returns a -> command) + -> (a -> Fay ()) -- ^ Success Handler + -> Fay () +call f g = ajaxCommand (f Returns) g + +-- ! Call a command, handling errors as well +callWithErrorHandling + :: (Returns a -> command) + -> (a -> Fay ()) -- ^ Success Handler + -> (Fay ()) -- ^ Failure Handler + -> Fay () +callWithErrorHandling f g h = ajaxCommandWithErrorHandling (f Returns) g h + +-- | Run the AJAX command. +ajaxCommand :: Automatic command + -> (Automatic a -> Fay ()) -- ^ Success Handler + -> Fay () +ajaxCommand = ffi "jQuery['ajax']({ url: window['yesodFayCommandPath'], type: 'POST', data: { json: JSON.stringify(%1) }, dataType: 'json', success : %2})" + +-- | Run the AJAX command, handling errors as well +ajaxCommandWithErrorHandling + :: Automatic command + -> (Automatic a -> Fay ()) -- ^ Success Handler + -> (Fay ()) -- ^ Failure Handler + -> Fay () +ajaxCommandWithErrorHandling = ffi "jQuery['ajax']({ url: window['yesodFayCommandPath'], type: 'POST', data: { json: JSON.stringify(%1) }, dataType: 'json', success : %2, error: %3})" +