diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,97 @@ +[![build](https://github.com/arsalan0c/cdp-hs/actions/workflows/build.yaml/badge.svg)](https://github.com/arsalan0c/cdp-hs/actions/workflows/build.yaml) +# cdp-hs + +A Haskell library for the [Chrome Devtools Protocol (CDP)](https://chromedevtools.github.io/devtools-protocol/), generated from the protocol's definition files. + +## Example usage + +Ensure Chrome is running with the remote debugging port enabled: + +``` +$ chromium --headless --remote-debugging-port=9222 https://wikipedia.com +``` + +The following program can be used to print a page to PDF, with Base64 encoded data being read in chunks: + +```hs +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Maybe +import Data.Default +import qualified Data.ByteString.Base64.Lazy as Base64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +import qualified CDP as CDP + +main :: IO () +main = do + let cfg = def + CDP.runClient cfg printPDF + +printPDF :: CDP.Handle -> IO () +printPDF handle = do + -- send the Page.printToPDF command + r <- CDP.sendCommandWait handle $ CDP.pPagePrintToPDF + { CDP.pPagePrintToPDFTransferMode = Just CDP.PPagePrintToPDFTransferModeReturnAsStream + } + + -- obtain stream handle from which to read pdf data + let streamHandle = fromJust . CDP.pagePrintToPDFStream $ r + + -- read pdf data 24000 bytes at a time + let params = CDP.PIORead streamHandle Nothing $ Just 24000 + reads <- whileTrue (not . CDP.iOReadEof) $ CDP.sendCommandWait handle params + let dat = map decode reads + BL.writeFile "mypdf.pdf" $ BL.concat dat + +decode :: CDP.IORead -> BL.ByteString +decode ior = if (CDP.iOReadBase64Encoded ior == Just True) + then Base64.decodeLenient lbs + else lbs + where + lbs = TL.encodeUtf8 . TL.fromStrict . CDP.iOReadData $ ior + +whileTrue :: Monad m => (a -> Bool) -> m a -> m [a] +whileTrue f act = do + a <- act + if f a + then pure . (a :) =<< whileTrue f act + else pure [a] +``` + +## Generating the CDP library + +``` +cabal run cdp-gen +``` + +## Current state + +[Project board](https://github.com/users/arsalan0c/projects/1) + +Commands and events for all non-deprecated domains are supported. +The following session functionalities are supported: +- creating a session: obtain a session id by using the `pTargetAttachToTarget` function to send a `Target.attachToTarget` command, passing `True` for the flatten argument +- send a command for a particular session: use the `sendCommandForSession` function with a session id +- subscribe to events for a particular session: + 1. register a handler with a session id + 2. send the command to enable events for the domain, with the same session id + +## Contributing + +PRs are welcome! If you would like to discuss changes or have any feedback, feel free to open an [issue](https://github.com/arsalan0c/cdp-hs/issues). + + +## Acknowledgements + +This began as a [Summer of Haskell](https://summer.haskell.org) / [GSoC](https://summerofcode.withgoogle.com) project. Albert Krewinkel ([@tarleb](https://github.com/tarleb)), Jasper Van der Jeugt ([@jaspervdj](https://github.com/jaspervdj)) and Romain Lesur ([@RLesur](https://github.com/rlesur)) provided valuable feedback and support which along with raising the library's quality, has made this all the more enjoyable to work on. + +## References + +- https://jaspervdj.be/posts/2013-09-01-controlling-chromium-in-haskell.html +- https://www.jsonrpc.org/specification diff --git a/cdp.cabal b/cdp.cabal new file mode 100644 --- /dev/null +++ b/cdp.cabal @@ -0,0 +1,318 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.34.6. +-- +-- see: https://github.com/sol/hpack + +name: cdp +version: 0.0.1.0 +synopsis: A library for the Chrome Devtools Protocol (CDP) +description: Chrome Devtools Protocol: https://chromedevtools.github.io/devtools-protocol/ + README: + Examples: +category: Package.Category +homepage: https://github.com/arsalan0c/cdp-hs#readme +bug-reports: https://github.com/arsalan0c/cdp-hs/issues +author: Arsalan Cheema +maintainer: Arsalan Cheema +license: BSD-3-Clause +build-type: Simple +extra-doc-files: + README.md + +source-repository head + type: git + location: https://github.com/arsalan0c/cdp-hs + +library + exposed-modules: + CDP + CDP.Domains + CDP.Domains.Accessibility + CDP.Domains.Animation + CDP.Domains.Audits + CDP.Domains.BackgroundService + CDP.Domains.BrowserTarget + CDP.Domains.CacheStorage + CDP.Domains.Cast + CDP.Domains.CSS + CDP.Domains.Database + CDP.Domains.Debugger + CDP.Domains.DeviceOrientation + CDP.Domains.DOMDebugger + CDP.Domains.DOMPageNetworkEmulationSecurity + CDP.Domains.DOMSnapshot + CDP.Domains.DOMStorage + CDP.Domains.EventBreakpoints + CDP.Domains.Fetch + CDP.Domains.HeadlessExperimental + CDP.Domains.HeapProfiler + CDP.Domains.IndexedDB + CDP.Domains.Input + CDP.Domains.Inspector + CDP.Domains.IO + CDP.Domains.LayerTree + CDP.Domains.Log + CDP.Domains.Media + CDP.Domains.Memory + CDP.Domains.Overlay + CDP.Domains.Performance + CDP.Domains.PerformanceTimeline + CDP.Domains.Profiler + CDP.Domains.Runtime + CDP.Domains.ServiceWorker + CDP.Domains.Storage + CDP.Domains.SystemInfo + CDP.Domains.Tethering + CDP.Domains.Tracing + CDP.Domains.WebAudio + CDP.Domains.WebAuthn + CDP.Endpoints + CDP.Internal.Utils + CDP.Runtime + CDP.Definition + CDP.Gen.Deprecated + CDP.Gen.Program + CDP.Gen.Snippets + Main + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + src + gen + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-example-endpoints + main-is: endpoints.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + examples + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , blaze-html + , blaze-markup + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , utf8-string + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-example-open-twitter + main-is: open-twitter.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + examples + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-example-print-page + main-is: print-page.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + examples + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , base64-bytestring + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-example-sessions + main-is: sessions.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + examples + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-example-subscribe + main-is: subscribe.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + examples + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +executable cdp-gen + main-is: Main.hs + other-modules: + CDP.Definition + CDP.Gen.Deprecated + CDP.Gen.Program + CDP.Gen.Snippets + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + gen + default-extensions: + Strict + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 + +test-suite cdp-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Paths_cdp + autogen-modules: + Paths_cdp + hs-source-dirs: + test + ghc-options: -Wall -threaded + build-depends: + aeson ==1.5.6.0 + , base ==4.14.3.0 + , bytestring ==0.10.12.0 + , cdp + , containers ==0.6.5.1 + , data-default ==0.7.1.1 + , directory ==1.3.6.0 + , extra ==1.7.9 + , filepath ==1.4.2.1 + , hspec + , http-conduit ==2.3.8 + , monad-loops ==0.4.3 + , mtl ==2.2.2 + , network-uri ==2.6.4.1 + , process ==1.6.13.2 + , random ==1.2.0 + , text ==1.2.4.1 + , vector ==0.12.3.1 + , websockets ==0.12.7.3 + default-language: Haskell2010 diff --git a/examples/endpoints.hs b/examples/endpoints.hs new file mode 100644 --- /dev/null +++ b/examples/endpoints.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Data.Default +import qualified Data.ByteString.Lazy.UTF8 as BS +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html.Renderer.Pretty as R + +import qualified CDP as CDP + +main :: IO () +main = do + CDP.endpoint def CDP.EPFrontend >>= + print . R.renderHtml . H.toHtml . BS.toString diff --git a/examples/open-twitter.hs b/examples/open-twitter.hs new file mode 100644 --- /dev/null +++ b/examples/open-twitter.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import CDP +import Data.Default (def) +import Control.Concurrent (threadDelay) +import Control.Monad (forever) + +main :: IO () +main = CDP.runClient def $ \handle -> forever $ do + sendCommand handle $ pTargetCreateTarget "https://twitter.com/GabriellaG439" + threadDelay $ 10 * 1000 * 1000 diff --git a/examples/print-page.hs b/examples/print-page.hs new file mode 100644 --- /dev/null +++ b/examples/print-page.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Maybe +import Data.Default +import qualified Data.ByteString.Base64.Lazy as Base64 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +import qualified CDP as CDP + +main :: IO () +main = do + let cfg = def + CDP.runClient cfg printPDF + +printPDF :: CDP.Handle -> IO () +printPDF handle = do + -- send the Page.printToPDF command + r <- CDP.sendCommandWait handle $ CDP.pPagePrintToPDF + { CDP.pPagePrintToPDFTransferMode = Just CDP.PPagePrintToPDFTransferModeReturnAsStream + } + + -- obtain stream handle from which to read pdf data + let streamHandle = fromJust . CDP.pagePrintToPDFStream $ r + + -- read pdf data 24000 bytes at a time + let params = CDP.PIORead streamHandle Nothing $ Just 24000 + reads <- whileTrue (not . CDP.iOReadEof) $ CDP.sendCommandWait handle params + let dat = map decode reads + BL.writeFile "mypdf.pdf" $ BL.concat dat + +decode :: CDP.IORead -> BL.ByteString +decode ior = if (CDP.iOReadBase64Encoded ior == Just True) + then Base64.decodeLenient lbs + else lbs + where + lbs = TL.encodeUtf8 . TL.fromStrict . CDP.iOReadData $ ior + +whileTrue :: Monad m => (a -> Bool) -> m a -> m [a] +whileTrue f act = do + a <- act + if f a + then pure . (a :) =<< whileTrue f act + else pure [a] diff --git a/examples/sessions.hs b/examples/sessions.hs new file mode 100644 --- /dev/null +++ b/examples/sessions.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Default +import Control.Monad (forever) +import Control.Concurrent (threadDelay) +import qualified Data.Text as T + +import qualified CDP as CDP + +main :: IO () +main = do + CDP.runClient def $ \handle -> do + sessionId <- attachTarget handle + subPageLoad handle sessionId + +-- Attaches to target, returning the session id +attachTarget :: CDP.Handle -> IO T.Text +attachTarget handle = do + -- get a target id + targetInfo <- head . CDP.targetGetTargetsTargetInfos <$> + (CDP.sendCommandWait handle $ CDP.PTargetGetTargets Nothing) + let targetId = CDP.targetTargetInfoTargetId targetInfo + -- get a session id by attaching to the target + CDP.targetAttachToTargetSessionId <$> do + CDP.sendCommandWait handle $ + -- to enable sessions, flatten must be set to True + CDP.PTargetAttachToTarget targetId (Just True) + +-- | Subscribes to page load events for a given session +subPageLoad :: CDP.Handle -> T.Text -> IO () +subPageLoad handle sessionId = do + -- register a handler for the page load event + CDP.subscribeForSession handle sessionId (print . CDP.pageLoadEventFiredTimestamp) + -- start receiving events + CDP.sendCommandForSessionWait handle sessionId CDP.pPageEnable + -- navigate to a page, triggering the page load event + CDP.sendCommandForSessionWait handle sessionId $ + CDP.pPageNavigate "http://haskell.foundation" + -- stop the program from terminating, to keep receiving events + forever $ do + threadDelay 1000 diff --git a/examples/subscribe.hs b/examples/subscribe.hs new file mode 100644 --- /dev/null +++ b/examples/subscribe.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified CDP as CDP +import Data.Default (def) +import Control.Concurrent (threadDelay) +import Control.Monad (forever) +import Control.Monad.Fix (mfix) + +main :: IO () +main = CDP.runClient def $ \handle -> do + CDP.sendCommandWait handle CDP.pPageEnable + sub1 <- mfix $ \sub -> CDP.subscribe handle $ \e -> do + putStrLn . show $ "1: " <> CDP.pageFrameUrl (CDP.pageFrameNavigatedFrame e) + CDP.unsubscribe handle sub + _ <- CDP.subscribe handle $ \e -> + putStrLn . show $ "2: " <> CDP.pageFrameUrl (CDP.pageFrameNavigatedFrame e) + forever $ threadDelay 1000 diff --git a/gen/CDP/Definition.hs b/gen/CDP/Definition.hs new file mode 100644 --- /dev/null +++ b/gen/CDP/Definition.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveGeneric #-} + +module CDP.Definition where +import System.Exit (exitFailure, exitSuccess) +import System.IO (stderr, hPutStrLn) +import qualified Data.ByteString.Lazy.Char8 as BSL +import System.Environment (getArgs) +import Control.Monad (forM_, mzero, join) +import Control.Applicative +import Data.Aeson(eitherDecode, Value(..), FromJSON(..), ToJSON(..),pairs,(.:), (.:?), (.=), (.!=), object) +import Data.Monoid((<>)) +import Data.Text (Text) +import qualified GHC.Generics + +data Version = Version { + versionMinor :: Text, + versionMajor :: Text + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Version where + parseJSON (Object v) = Version <$> v .: "minor" <*> v .: "major" + parseJSON _ = mzero + + +data Items = Items { + itemsType :: Maybe Text, + itemsRef :: Maybe Text + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Items where + parseJSON (Object v) = Items <$> v .:? "type" <*> v .:? "$ref" + parseJSON _ = mzero + + +data Property = Property { + propertyItems :: Maybe Items, + propertyExperimental :: Bool, + propertyName :: Text, + propertyType :: Maybe Text, + propertyEnum :: Maybe [Text], + propertyOptional :: Bool, + propertyRef :: Maybe Text, + propertyDescription :: Maybe Text, + propertyDeprecated :: Bool + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Property where + parseJSON (Object v) = Property + <$> v .:? "items" + <*> v .:? "experimental" .!= False + <*> v .: "name" + <*> v .:? "type" + <*> v .:? "enum" + <*> v .:? "optional" .!= False + <*> v .:? "$ref" + <*> v .:? "description" + <*> v .:? "deprecated" .!= False + parseJSON _ = mzero + + +data Command = Command { + commandExperimental :: Bool, + commandName :: Text, + commandReturns :: [Property], + commandParameters :: [Property], + commandRedirect :: Maybe Text, + commandDescription :: Maybe Text, + commandDeprecated :: Bool + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Command where + parseJSON (Object v) = Command + <$> v .:? "experimental" .!= False + <*> v .: "name" + <*> v .:? "returns" .!= [] + <*> v .:? "parameters" .!= [] + <*> v .:? "redirect" + <*> v .:? "description" + <*> v .:? "deprecated" .!= False + parseJSON _ = mzero + + +data Type = Type { + typeItems :: Maybe Items, + typeExperimental :: Bool, + typeId :: Text, + typeType :: Text, + typeEnum :: Maybe [Text], + typeProperties :: Maybe [Property], + typeDescription :: Maybe Text, + typeDeprecated :: Bool + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Type where + parseJSON (Object v) = Type + <$> v .:? "items" + <*> v .:? "experimental" .!= False + <*> v .: "id" + <*> v .: "type" + <*> v .:? "enum" + <*> v .:? "properties" + <*> v .:? "description" + <*> v .:? "deprecated" .!= False + parseJSON _ = mzero + + +data Event = Event { + eventExperimental :: Bool, + eventName :: Text, + eventParameters :: [Property], + eventDescription :: Maybe Text, + eventDeprecated :: Bool + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Event where + parseJSON (Object v) = Event + <$> v .:? "experimental" .!= False + <*> v .: "name" + <*> v .:? "parameters" .!= [] + <*> v .:? "description" + <*> v .:? "deprecated" .!= False + parseJSON _ = mzero + + +data Domain = Domain { + domainCommands :: [Command], + domainDomain :: Text, + domainDependencies :: [Text], + domainExperimental :: Bool, + domainTypes :: [Type], + domainEvents :: [Event], + domainDescription :: Maybe Text, + domainDeprecated :: Bool + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON Domain where + parseJSON (Object v) = Domain + <$> v .: "commands" + <*> v .: "domain" + <*> v .:? "dependencies" .!= [] + <*> v .:? "experimental" .!= False + <*> v .:? "types" .!= [] + <*> v .:? "events" .!= [] + <*> v .:? "description" + <*> v .:? "deprecated" .!= False + parseJSON _ = mzero + + +data TopLevel = TopLevel { + topLevelVersion :: Version, + topLevelDomains :: [Domain] + } deriving (Show,Eq,GHC.Generics.Generic) + + +instance FromJSON TopLevel where + parseJSON (Object v) = TopLevel <$> v .: "version" <*> v .: "domains" + parseJSON _ = mzero + + + + +-- | Use parser to get TopLevel object +parse :: FilePath -> IO TopLevel +parse filename = do + input <- BSL.readFile filename + case eitherDecode input of + Left errTop -> fatal $ case (eitherDecode input :: Either String Value) of + Left err -> "Invalid JSON file: " ++ filename ++ "\n " ++ err + Right _ -> "Mismatched JSON value from file: " ++ filename + ++ "\n" ++ errTop + Right r -> return (r :: TopLevel) + where + fatal :: String -> IO a + fatal msg = do hPutStrLn stderr msg + exitFailure diff --git a/gen/CDP/Gen/Deprecated.hs b/gen/CDP/Gen/Deprecated.hs new file mode 100644 --- /dev/null +++ b/gen/CDP/Gen/Deprecated.hs @@ -0,0 +1,32 @@ +-- | Module for filtering out deprecated things. +{-# LANGUAGE RecordWildCards #-} +module CDP.Gen.Deprecated + ( removeDeprecated + ) where + +import CDP.Definition + +removeDeprecated :: TopLevel -> TopLevel +removeDeprecated topLevel@TopLevel {..} = topLevel + { topLevelDomains = + map goDomain . filter (not . domainDeprecated) $ topLevelDomains + } + where + goDomain domain@Domain {..} = domain + { domainCommands = map goCommand $ filter (not . commandDeprecated) domainCommands + , domainTypes = map goType $ filter (not . typeDeprecated) domainTypes + , domainEvents = map goEvent $ filter (not . eventDeprecated) domainEvents + } + + goCommand command@Command {..} = command + { commandReturns = filter (not . propertyDeprecated) commandReturns + , commandParameters = filter (not . propertyDeprecated) commandParameters + } + + goType ty@Type {..} = ty + { typeProperties = filter (not . propertyDeprecated) <$> typeProperties + } + + goEvent event@Event {..} = event + { eventParameters = filter (not . propertyDeprecated) eventParameters + } diff --git a/gen/CDP/Gen/Program.hs b/gen/CDP/Gen/Program.hs new file mode 100644 --- /dev/null +++ b/gen/CDP/Gen/Program.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE OverloadedStrings, FlexibleContexts, TupleSections, TypeOperators #-} + +module CDP.Gen.Program + ( Program (..) + , genProgram + , genProtocolModule + + , ComponentName (..) + ) where + +import Control.Arrow +import Data.List +import Data.Maybe +import Data.Char +import Control.Monad +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Graph as Graph +import qualified Data.Text as T + +import qualified CDP.Definition as D +import qualified CDP.Gen.Snippets as Snippets + +----------- Start of program generation ----------- + +data Program = Program + { pComponents :: Map.Map ComponentName T.Text + , pComponentImports :: T.Text + } + +data Context = Context { ctxDomainComponents :: DomainComponents } + +genProgram :: [D.Domain] -> Program +genProgram delts = Program + { pComponents = allComponents ctx $ Map.elems dc + , pComponentImports = T.unlines $ allComponentImports ctx + } + where + ctx = Context dc + dc = domainComponents delts + +----------- Generation of global types / values ----------- + +genProtocolModule :: [ComponentName] -> T.Text -> T.Text +genProtocolModule names source = T.unlines + [ "{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE FlexibleContexts #-}" + , "{-# LANGUAGE MultiParamTypeClasses #-}" + , "{-# LANGUAGE FlexibleInstances #-}" + , "{-# LANGUAGE DeriveGeneric #-}" + , "" + , protocolModuleHeader names + , Snippets.domainImports + , source + ] + +allComponentImports :: Context -> [T.Text] +allComponentImports = Set.toList . Set.fromList . + concatMap ((\n -> [importDomain False n, importDomain True n]) . unComponentName . cName) . Map.elems . ctxDomainComponents + +allComponents :: Context -> [Component] -> Map.Map ComponentName T.Text +allComponents ctx components = Map.fromList . + map (cName &&& genComponent ctx) $ + components + +----------- Generation of domain types / values ----------- + +genComponent :: Context -> Component -> T.Text +genComponent ctx component = T.intercalate "\n\n" $ + [ Snippets.domainLanguageExtensions + , formatComponentDescription component + , domainModuleHeader cn + , Snippets.domainImports + , T.unlines $ map (importDomain True) deps + , T.unlines $ map (genDomain ctx) delts + ] + where + deps = Set.toList . Set.fromList . map unComponentName . + map (domainToComponentName ctx) . concatMap snd . Map.elems $ cDomDeps component + delts = map fst . Map.elems $ cDomDeps component + cn = unComponentName . cName $ component + +genDomain :: Context -> D.Domain -> T.Text +genDomain ctx domainElt = T.unlines . intercalate [""] $ + map (genType ctx dn) (D.domainTypes domainElt) ++ + map (genEventReturnType ctx dn) (D.domainEvents domainElt) ++ + map (genCommand ctx dn) (D.domainCommands domainElt) + where + dn = domainName domainElt + +genType :: Context -> T.Text -> D.Type -> [T.Text] +genType ctx domainName telt = + desc ++ + (case D.typeEnum telt of + Just enumValues -> genTypeEnum ctx tn enumValues + Nothing -> case tytelt of + "object" -> case tpeltsM of + Nothing -> [genTypeSynonynm ctx domainName tn] + Just tpelts -> + genRecordType ctx domainName tn tpelts ++ + genRecordFromJson tn tpelts ++ + genRecordToJson tn tpelts + ty -> [T.unwords ["type", tn, "=", lty]]) + where + desc = formatDescription . Just $ + "Type '" <> domainName <> "." <> D.typeId telt <> "'." <> + maybe "" (\x -> "\n" <> x) (D.typeDescription telt) + lty = leftType ctx domainName (Just tytelt) Nothing (D.typeItems telt) + tytelt = D.typeType telt + tpeltsM = D.typeProperties telt + tn = typeNameHS domainName telt + +genTypeEnum :: Context -> T.Text -> [T.Text] -> [T.Text] +genTypeEnum _ typeEnumName values = + [T.unwords ["data", typeEnumName, "=", T.intercalate " | " constructors]] ++ + indent [derivingOrd] ++ + genFromJSONInstanceEnum typeEnumName values constructors ++ + genToJSONInstanceEnum typeEnumName values constructors + where + constructors = map (tyNameHS typeEnumName) values + +genEventReturnType :: Context -> T.Text -> D.Event -> [T.Text] +genEventReturnType ctx domainName eventElt = + desc ++ + (case evelts of + [] -> ["data " <> evrn <> " = " <> evrn] ++ indent [derivingBase] + _ -> genRecordType ctx domainName evrn evelts) ++ + (genRecordFromJson evrn evelts) ++ + ["instance Event " <> evrn <> " where"] ++ + indent ["eventName _ = \"" <> eventName domainName eventElt <> "\""] + where + desc = formatDescription . Just $ "Type of the '" <> + (eventName domainName eventElt) <> "' event." + evelts = D.eventParameters eventElt + evrn = eventNameHS domainName eventElt + +genCommand :: Context -> T.Text -> D.Command -> [T.Text] +genCommand ctx domainName commandElt = + formatDescription (D.commandDescription commandElt) ++ + [""] ++ + formatDescription (Just $ "Parameters of the '" <> cn <> "' command.") ++ + genRecordType ctx domainName ptn pelts ++ + genRecordSmartConstructor ctx domainName ptn pelts ++ + genRecordToJson ptn pelts ++ + (if null relts then [] else genRecordType ctx domainName rtn relts) ++ + (if null relts then [] else genRecordFromJson rtn relts) ++ + commandInstance + where + cn = commandName domainName commandElt + ptn = commandParamsNameHS domainName commandElt + rtn = commandNameHS domainName commandElt + + pelts = D.commandParameters commandElt + + relts = D.commandReturns commandElt + + commandAssociatedType = if null relts then "()" else rtn + commandInstance = + ["instance Command " <> ptn <> " where"] ++ + indent ["type CommandResponse " <> ptn <> " = " <> commandAssociatedType] ++ + indent ["commandName _ = \"" <> cn <> "\""] ++ + indent ["fromJSON = const . A.Success . const ()" | (null relts)] + +genRecordType :: Context -> T.Text -> T.Text -> [D.Property] -> [T.Text] +genRecordType ctx domainName recName props = + (do + p <- props + e <- maybeToList $ D.propertyEnum p + genTypeEnum ctx (tyNameHS "" (fieldNameHS recName $ D.propertyName p)) e) ++ + [ "data " <> recName <> " = " <> recName] ++ + (indent $ case props of + [] -> [] + _ -> + ["{"] ++ + (indent $ do + (isLast, prop) <- markLast props + let (fn, fty) = propertyHsSig ctx domainName recName prop + comma = if isLast then "" else "," + formatDescription (D.propertyDescription prop) ++ + [fn <> " :: " <> fty <> comma]) ++ + ["}"]) ++ + [" deriving (Eq, Show)"] + +genRecordSmartConstructor :: Context -> T.Text -> T.Text -> [D.Property] -> [T.Text] +genRecordSmartConstructor ctx domainName recName props = + [conName] ++ + (indent $ do + (isFirstParam, (mbDesc, ty)) <- markFirst types + let d1 = formatDescription mbDesc + d2 + | length d1 == 0 = d1 + | otherwise = "{-" : d1 ++ ["-}"] + d2 ++ + [(if isFirstParam then ":: " else "-> ") <> ty]) ++ + [conName] ++ + indent args ++ + indent ["= " <> recName] ++ + (indent . indent $ do + prop <- props + pure $ if D.propertyOptional prop + then "Nothing" + else argName prop) + where + conName = uncapitalizeFirst recName + requiredProps = filter (not . D.propertyOptional) props + types = (do + prop <- requiredProps + let (_, ty) = propertyHsSig ctx domainName recName prop + pure (D.propertyDescription prop, ty)) ++ + [ (Nothing, recName) ] + args = do + prop <- requiredProps + guard . not $ D.propertyOptional prop + pure $ argName prop + + argName = ("arg_" <>) . fieldNameHS recName . D.propertyName + +genRecordFromJson :: T.Text -> [D.Property] -> [T.Text] +genRecordFromJson recName props = + ["instance FromJSON " <> recName <> " where"] ++ + (indent $ case props of + [] -> ["parseJSON _ = pure " <> recName] + _ -> + ["parseJSON = A.withObject \"" <> recName <> "\" $ \\o -> " <> recName] ++ + (indent $ do + (isFirst, prop) <- markFirst props + pure $ + (if isFirst then "<$>" else "<*>") <> + " o " <> (if D.propertyOptional prop then "A..:?" else "A..:") <> + " \"" <> D.propertyName prop <> "\"")) + +genRecordToJson :: T.Text -> [D.Property] -> [T.Text] +genRecordToJson recName params = + ["instance ToJSON " <> recName <> " where"] ++ + (case params of + [] -> [" toJSON _ = A.Null"] + _ -> + [" toJSON p = A.object $ catMaybes ["] ++ + [ + " " <> T.intercalate ",\n " + [ "(\"" <> D.propertyName prop <> "\" A..=) <$> " <> + (if D.propertyOptional prop then "" else "Just ") <> + "(" <> fieldNameHS recName (D.propertyName prop) <> " p)" + | prop <- params + ] + ] ++ + [" ]"]) + +propertyHsSig :: Context -> T.Text -> T.Text -> D.Property -> (T.Text, T.Text) +propertyHsSig ctx domainName recName prop = case D.propertyEnum prop of + Just _ -> (fn, (if D.propertyOptional prop then "Maybe " else "") <> ftn) + Nothing -> (fn, ) $ genEltType ctx domainName (D.propertyOptional prop) + (D.propertyType prop) + (D.propertyRef prop) + (D.propertyItems prop) + where + ftn = tyNameHS "" fn + fn = fieldNameHS recName . D.propertyName $ prop + +genTypeSynonynm :: Context -> T.Text -> T.Text -> T.Text +genTypeSynonynm ctx domainName typeName = T.unwords ["type", typeName, "=", typeCDPToHS ctx domainName "object" Nothing] + +----------- Generation rules ----------- +----- Docs ----- +formatComponentDescription :: Component -> T.Text +formatComponentDescription component = T.unlines $ + ["{- |"] ++ + (do + (delt, _) <- Map.elems $ cDomDeps component + ["= " <> domainName delt] <> [""] ++ + maybe [] T.lines (D.domainDescription delt)) ++ + ["-}"] + +formatDescription :: Maybe T.Text -> [T.Text] +formatDescription = maybe [] (indentWith "-- | " "-- " . T.lines) + + +----- Imports ----- +importDomain :: Bool -> T.Text -> T.Text +importDomain as' domainName = T.unwords $ + if as' then imp ++ ["as", domainName] else imp + where + imp = ["import", domainModuleName domainName] + +componentToImport :: [ComponentName] -> [T.Text] +componentToImport = map (("module " <>) . domainModuleName . unComponentName) + +protocolModuleHeader :: [ComponentName] -> T.Text +protocolModuleHeader names = T.unlines + [ mod + , "( " <> T.intercalate "\n, " exports + , ") where" + ] + where + mod = T.unwords [ "module", protocolModuleName ] + + exports = componentToImport names + +protocolModuleName :: T.Text +protocolModuleName = "CDP.Domains" + +domainModuleHeader :: T.Text -> T.Text +domainModuleHeader domainName = T.unwords ["module", domainModuleName domainName, "(module", domainModuleName domainName <>")", "where"] + +domainModuleName :: T.Text -> T.Text +domainModuleName domainName = T.intercalate "." ["CDP", "Domains", domainName] + +domainQualifiedName :: T.Text -> T.Text -> T.Text +domainQualifiedName domainName n = T.intercalate "." [domainName, n] + +domainName :: D.Domain -> T.Text +domainName = D.domainDomain + +----- JSON ----- + +genFromJSONInstanceEnum :: T.Text -> [T.Text] -> [T.Text] -> [T.Text] +genFromJSONInstanceEnum name vals hsVals = + ["instance FromJSON " <> name <> " where"] ++ + (indent $ + ["parseJSON = A.withText " <> (T.pack . show) name <> " $ \\v -> case v of"] ++ + (indent $ do + (v, hsv) <- zip vals (map ("pure " <>) hsVals) ++ [emptyCase name] + pure $ T.pack (show v) <> " -> " <> hsv)) + +genToJSONInstanceEnum :: T.Text -> [T.Text] -> [T.Text] -> [T.Text] +genToJSONInstanceEnum name vals hsVals = + ["instance ToJSON " <> name <> " where"] ++ + (indent $ + ["toJSON v = A.String $ case v of"] ++ + (indent $ do + (v, hsv) <- zip vals hsVals + pure $ hsv <> " -> " <> T.pack (show v))) + +----- Types ----- +genEltType :: Context -> T.Text -> Bool -> Maybe T.Text -> Maybe T.Text -> Maybe D.Items -> T.Text +genEltType ctx name isOptional t1 t2 items = (if isOptional then "Maybe " else "") <> (leftType ctx name t1 t2 items) + +leftType :: Context -> T.Text -> Maybe T.Text -> Maybe T.Text -> Maybe D.Items -> T.Text +leftType ctx _ (Just ty1) (Just ty2) _ = error "impossible" +leftType ctx domain (Just ty) _ itemsElt = typeCDPToHS ctx domain ty itemsElt +leftType ctx domain _ (Just ty) itemsElt = typeCDPToHS ctx domain ty itemsElt +leftType ctx _ _ _ _ = error "no type found" + +typeCDPToHS :: Context -> T.Text -> T.Text -> Maybe D.Items -> T.Text +typeCDPToHS ctx _ "object" _ = "[(T.Text, T.Text)]" +typeCDPToHS ctx domain "array" (Just items) = "[" <> (leftType ctx domain (D.itemsType items) (D.itemsRef items) Nothing) <> "]" +typeCDPToHS ctx _ ty (Just items) = error . T.unpack $ "non-array type with items: " <> ty +typeCDPToHS ctx domain ty Nothing = convertType ctx domain ty + +convertType :: Context -> T.Text -> T.Text -> T.Text +convertType _ _ "string" = "T.Text" +convertType _ _ "integer" = "Int" +convertType _ _ "boolean" = "Bool" +convertType _ _ "number" = "Double" +convertType _ _ "()" = "()" +convertType _ _ "any" = "A.Value" +convertType _ _ "array" = error "got array conversion" +convertType _ _ "object" = error "got object type" +convertType _ _ "" = error "got empty type" +convertType ctx domain s = case T.splitOn "." s of + [otherDomain, ty] -> if cn otherDomain == cn domain + then tyNameHS otherDomain ty -- both domains are in the same component, so the type is not qualified + else domainQualifiedName (cn otherDomain) (tyNameHS otherDomain ty) + _ -> tyNameHS domain s + where + cn dn = unComponentName . domainToComponentName ctx $ dn + +----- Dependencies ----- +{- : Domain dependencies specified in the protocol seem inaccurate: + https://bugs.chromium.org/p/chromium/issues/detail?id=1354980#c0 + + So they are collected by inspecting each domain. +-} + +domainToComponentName :: Context -> T.Text -> ComponentName +domainToComponentName ctx domainName = cName . (flip (Map.!) domainName) . ctxDomainComponents $ ctx + +newtype ComponentName = ComponentName { unComponentName :: T.Text } + deriving (Show, Eq, Ord) + +type DomainDependencies = Map.Map T.Text (D.Domain, [T.Text]) +data Component = Component { + cName :: ComponentName +, cDomDeps :: DomainDependencies +} + +type DomainComponents = Map.Map T.Text Component + -- original domain name, component the domain belongs to + -- domain name for each vertex is the modified domain name +type Vertex = (D.Domain, T.Text, [T.Text]) -- domain, domain name, domain dependencies + +domainComponents :: [D.Domain] -> DomainComponents +domainComponents delts = Map.fromList . concatMap verticesToDomainComponents $ vsc2 + where + vsc2 = map removeSameComponentDependencies vsc1 + vsc1 = map Graph.flattenSCC . Graph.stronglyConnCompR $ g + g = map (\delt -> (delt, domainName delt, deps delt)) delts + deps = Set.toList . domainDependencies + +verticesToDomainComponents :: [Vertex] -> [(T.Text, Component)] +verticesToDomainComponents vs = map (,c) dns + where + dns = map vertexToDomainName vs + c = verticesToComponent vs + +vertexToDomainName :: Vertex -> T.Text +vertexToDomainName (_,dn,_) = dn + +verticesToComponent :: [Vertex] -> Component +verticesToComponent vs = Component cn . Map.fromList . map toComponent $ vs + where + toComponent (delt,dn,deps) = (dn, (delt, deps)) + cn = componentName vs + +componentName :: [Vertex] -> ComponentName +componentName [v] = ComponentName $ vertexToDomainName v +componentName vs = ComponentName $ mconcat . map vertexToDomainName $ vs + +removeSameComponentDependencies :: [Vertex] -> [Vertex] +removeSameComponentDependencies vs = map (go vs) vs + where + go vs (delt, dn, deps) = (delt,dn,) . Set.toList $ + (Set.fromList deps) `Set.difference` dns + dns = Set.fromList $ map vertexToDomainName vs + +domainDependencies :: D.Domain -> Set.Set T.Text +domainDependencies delt = removeSelf . Set.fromList . concat $ + [ concatMap typeDependencies $ D.domainTypes delt + , concatMap commandDependencies $ D.domainCommands delt + , concatMap eventDependencies $ D.domainEvents delt + ] + where + removeSelf = Set.filter (/= dn) + dn = domainName delt + +typeDependencies :: D.Type -> [T.Text] +typeDependencies telt = case D.typeEnum telt of + Just _ -> [] + Nothing -> case D.typeType telt of + "array" -> maybe [] pure . join $ itemDependencies <$> D.typeItems telt + "object" -> fromMaybe [] $ catMaybes . map propertyDependencies <$> D.typeProperties telt + s -> maybe [] pure $ refTypeToDomain s + +commandDependencies :: D.Command -> [T.Text] +commandDependencies celt = concat + [ catMaybes . map propertyDependencies $ D.commandReturns celt + , catMaybes . map propertyDependencies $ D.commandParameters celt + ] + +eventDependencies :: D.Event -> [T.Text] +eventDependencies evelt = + catMaybes . map propertyDependencies $ D.eventParameters evelt + +propertyDependencies :: D.Property -> Maybe T.Text +propertyDependencies pelt = case D.propertyEnum pelt of + Just _ -> Nothing + Nothing -> case D.propertyRef pelt of + Just r -> refTypeToDomain r + Nothing -> case D.propertyType pelt of + Just "object" -> Nothing + Just "array" -> itemDependencies =<< D.propertyItems pelt + Just s -> refTypeToDomain s + _ -> Nothing + +itemDependencies :: D.Items -> Maybe T.Text +itemDependencies itelt = refTypeToDomain =<< D.itemsRef itelt + +----- Names ----- +eventName :: T.Text -> D.Event -> T.Text +eventName domainName ev = (domainName <>) . ("." <>) . D.eventName $ ev +eventNameHS :: T.Text -> D.Event -> T.Text +eventNameHS domainName ev = tyNameHS domainName (D.eventName ev) + +commandName :: T.Text -> D.Command -> T.Text +commandName domainName c = (domainName <>) . ("." <>) . D.commandName $ c +commandNameHS :: T.Text -> D.Command -> T.Text +commandNameHS domainName c = tyNameHS domainName (D.commandName c) +commandParamsNameHS :: T.Text -> D.Command -> T.Text +commandParamsNameHS domainName c = paramsTypePrefix $ commandNameHS domainName c + +typeNameHS :: T.Text -> D.Type -> T.Text +typeNameHS domainName t = tyNameHS domainName (D.typeId t) + +tyNameHS :: T.Text -> T.Text -> T.Text +tyNameHS prefix tyName = + capitalizeFirst prefix <> capitalizeFirst (hyphensToCapitalize tyName) + +fieldNameHS :: T.Text -> T.Text -> T.Text +fieldNameHS tyName fieldName = uncapitalizeFirst tyName <> capitalizeFirst fieldName + +paramsTypePrefix :: T.Text -> T.Text +paramsTypePrefix = ("P" <>) + +refTypeToDomain :: T.Text -> Maybe T.Text +refTypeToDomain r = case T.splitOn "." r of + [domain, _] -> Just domain + _ -> Nothing + +----- +emptyCase :: T.Text -> (T.Text, T.Text) +emptyCase name = ("_", T.unwords ["fail", (T.pack . show) $ "failed to parse " <> name]) + +derivingBase :: T.Text +derivingBase = "deriving (Eq, Show, Read)" +derivingOrd :: T.Text +derivingOrd = "deriving (Ord, Eq, Show, Read)" + +----------- Utilities ----------- + +indent :: [T.Text] -> [T.Text] +indent = indentWith " " " " + +indentWith :: T.Text -> T.Text -> [T.Text] -> [T.Text] +indentWith _ _ [] = [] +indentWith firstLine otherLines (x : xs) = + (firstLine <> x) : map (otherLines <>) xs + +capitalizeFirst :: T.Text -> T.Text +capitalizeFirst t = maybe t (\(first, rest) -> T.singleton (toUpper first) `T.append` rest) . T.uncons $ t + +uncapitalizeFirst :: T.Text -> T.Text +uncapitalizeFirst t = maybe t (\(first, rest) -> T.singleton (toLower first) `T.append` rest) . T.uncons $ t + +markFirst :: [a] -> [(Bool, a)] +markFirst = zip (True : repeat False) + +markLast :: [a] -> [(Bool, a)] +markLast [] = [] +markLast (x : []) = [(True, x)] +markLast (x : y : z) = (False, x) : markLast (y : z) + +-- | Changes things like "a-rate" to "aRate" +hyphensToCapitalize :: T.Text -> T.Text +hyphensToCapitalize txt + | T.null after = before + | otherwise = + before <> capitalizeFirst (hyphensToCapitalize (T.drop 1 after)) + where + (before, after) = T.break (== '-') txt diff --git a/gen/CDP/Gen/Snippets.hs b/gen/CDP/Gen/Snippets.hs new file mode 100644 --- /dev/null +++ b/gen/CDP/Gen/Snippets.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module CDP.Gen.Snippets where + +import qualified Data.Text as T + +domainLanguageExtensions :: T.Text +domainLanguageExtensions = T.unlines + [ "{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-}" + , "{-# LANGUAGE ScopedTypeVariables #-}" + , "{-# LANGUAGE FlexibleContexts #-}" + , "{-# LANGUAGE MultiParamTypeClasses #-}" + , "{-# LANGUAGE FlexibleInstances #-}" + , "{-# LANGUAGE DeriveGeneric #-}" + , "{-# LANGUAGE TypeFamilies #-}" + ] + +domainImports :: T.Text +domainImports = T.unlines + [ "import Control.Applicative ((<$>))" + , "import Control.Monad" + , "import Control.Monad.Loops" + , "import Control.Monad.Trans (liftIO)" + , "import qualified Data.Map as M" + , "import Data.Maybe " + , "import Data.Functor.Identity" + , "import Data.String" + , "import qualified Data.Text as T" + , "import qualified Data.List as List" + , "import qualified Data.Text.IO as TI" + , "import qualified Data.Vector as V" + , "import Data.Aeson.Types (Parser(..))" + , "import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=), (.!=), (.:!))" + , "import qualified Data.Aeson as A" + , "import qualified Network.HTTP.Simple as Http" + , "import qualified Network.URI as Uri" + , "import qualified Network.WebSockets as WS" + , "import Control.Concurrent" + , "import qualified Data.ByteString.Lazy as BS" + , "import qualified Data.Map as Map" + , "import Data.Proxy" + , "import System.Random" + , "import GHC.Generics" + , "import Data.Char" + , "import Data.Default" + , "" + , "import CDP.Internal.Utils" + ] diff --git a/gen/Main.hs b/gen/Main.hs new file mode 100644 --- /dev/null +++ b/gen/Main.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Foldable (for_) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Map as Map +import qualified System.FilePath as FP +import qualified System.Directory as Dir +import qualified System.IO as IO + +import qualified CDP.Definition as D +import qualified CDP.Gen.Program as GP +import CDP.Gen.Deprecated (removeDeprecated) + +main :: IO () +main = do + domains <- fmap concat . mapM (fmap D.topLevelDomains . fmap removeDeprecated . D.parse) $ + [ browserDefinitionPath + , jsDefinitionPath + ] + + let program = GP.genProgram domains + + for_ (Map.toList . GP.pComponents $ program) $ \(dn,d) -> do + let path = domainPath . T.unpack . GP.unComponentName $ dn + IO.hPutStrLn IO.stderr $ "Writing domain to " ++ path ++ "..." + T.writeFile path d + + let protocol = GP.genProtocolModule (Map.keys . GP.pComponents $ program) $ + GP.pComponentImports program + + IO.hPutStrLn IO.stderr $ "Writing protocol to " ++ protocolModulePath ++ "..." + T.writeFile protocolModulePath protocol + where + domainPath dn = domainDir FP. FP.addExtension dn "hs" + domainDir = "src/CDP/Domains" + protocolModulePath = "src/CDP/Domains.hs" + jsDefinitionPath = "devtools-protocol/json/js_protocol.json" + browserDefinitionPath = "devtools-protocol/json/browser_protocol.json" diff --git a/src/CDP.hs b/src/CDP.hs new file mode 100644 --- /dev/null +++ b/src/CDP.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +module CDP + ( Error (..) + , ProtocolError (..) + , EPBrowserVersion (..) + , EPAllTargets (..) + , EPCurrentProtocol (..) + , EPOpenNewTab (..) + , EPActivateTarget (..) + , EPCloseTarget (..) + , EPFrontend (..) + , Endpoint + , EndpointResponse + , SomeEndpoint (..) + , BrowserVersion (..) + , TargetInfo (..) + , TargetId + , parseUri + , fromSomeEndpoint + , endpoint + , connectToTab + + , ClientApp + , Handle + , Config(..) + , runClient + + , Subscription + , subscribe + , subscribeForSession + , unsubscribe + + , Command (..) + , SomeCommand (..) + , Promise (..) + , fromSomeCommand + , readPromise + , sendCommand + , sendCommandForSession + , sendCommandWait + , sendCommandForSessionWait + + , module CDP.Domains + ) where + +import Data.Proxy (Proxy) + +import CDP.Domains +import CDP.Runtime diff --git a/src/CDP/Domains.hs b/src/CDP/Domains.hs new file mode 100644 --- /dev/null +++ b/src/CDP/Domains.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} + +module CDP.Domains +( module CDP.Domains.Accessibility +, module CDP.Domains.Animation +, module CDP.Domains.Audits +, module CDP.Domains.BackgroundService +, module CDP.Domains.BrowserTarget +, module CDP.Domains.CSS +, module CDP.Domains.CacheStorage +, module CDP.Domains.Cast +, module CDP.Domains.DOMDebugger +, module CDP.Domains.DOMPageNetworkEmulationSecurity +, module CDP.Domains.DOMSnapshot +, module CDP.Domains.DOMStorage +, module CDP.Domains.Database +, module CDP.Domains.Debugger +, module CDP.Domains.DeviceOrientation +, module CDP.Domains.EventBreakpoints +, module CDP.Domains.Fetch +, module CDP.Domains.HeadlessExperimental +, module CDP.Domains.HeapProfiler +, module CDP.Domains.IO +, module CDP.Domains.IndexedDB +, module CDP.Domains.Input +, module CDP.Domains.Inspector +, module CDP.Domains.LayerTree +, module CDP.Domains.Log +, module CDP.Domains.Media +, module CDP.Domains.Memory +, module CDP.Domains.Overlay +, module CDP.Domains.Performance +, module CDP.Domains.PerformanceTimeline +, module CDP.Domains.Profiler +, module CDP.Domains.Runtime +, module CDP.Domains.ServiceWorker +, module CDP.Domains.Storage +, module CDP.Domains.SystemInfo +, module CDP.Domains.Tethering +, module CDP.Domains.Tracing +, module CDP.Domains.WebAudio +, module CDP.Domains.WebAuthn +) where + +import Control.Applicative ((<$>)) +import Control.Monad +import Control.Monad.Loops +import Control.Monad.Trans (liftIO) +import qualified Data.Map as M +import Data.Maybe +import Data.Functor.Identity +import Data.String +import qualified Data.Text as T +import qualified Data.List as List +import qualified Data.Text.IO as TI +import qualified Data.Vector as V +import Data.Aeson.Types (Parser(..)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=), (.!=), (.:!)) +import qualified Data.Aeson as A +import qualified Network.HTTP.Simple as Http +import qualified Network.URI as Uri +import qualified Network.WebSockets as WS +import Control.Concurrent +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map +import Data.Proxy +import System.Random +import GHC.Generics +import Data.Char +import Data.Default + +import CDP.Internal.Utils + +import CDP.Domains.Accessibility +import CDP.Domains.Accessibility as Accessibility +import CDP.Domains.Animation +import CDP.Domains.Animation as Animation +import CDP.Domains.Audits +import CDP.Domains.Audits as Audits +import CDP.Domains.BackgroundService +import CDP.Domains.BackgroundService as BackgroundService +import CDP.Domains.BrowserTarget +import CDP.Domains.BrowserTarget as BrowserTarget +import CDP.Domains.CSS +import CDP.Domains.CSS as CSS +import CDP.Domains.CacheStorage +import CDP.Domains.CacheStorage as CacheStorage +import CDP.Domains.Cast +import CDP.Domains.Cast as Cast +import CDP.Domains.DOMDebugger +import CDP.Domains.DOMDebugger as DOMDebugger +import CDP.Domains.DOMPageNetworkEmulationSecurity +import CDP.Domains.DOMPageNetworkEmulationSecurity as DOMPageNetworkEmulationSecurity +import CDP.Domains.DOMSnapshot +import CDP.Domains.DOMSnapshot as DOMSnapshot +import CDP.Domains.DOMStorage +import CDP.Domains.DOMStorage as DOMStorage +import CDP.Domains.Database +import CDP.Domains.Database as Database +import CDP.Domains.Debugger +import CDP.Domains.Debugger as Debugger +import CDP.Domains.DeviceOrientation +import CDP.Domains.DeviceOrientation as DeviceOrientation +import CDP.Domains.EventBreakpoints +import CDP.Domains.EventBreakpoints as EventBreakpoints +import CDP.Domains.Fetch +import CDP.Domains.Fetch as Fetch +import CDP.Domains.HeadlessExperimental +import CDP.Domains.HeadlessExperimental as HeadlessExperimental +import CDP.Domains.HeapProfiler +import CDP.Domains.HeapProfiler as HeapProfiler +import CDP.Domains.IO +import CDP.Domains.IO as IO +import CDP.Domains.IndexedDB +import CDP.Domains.IndexedDB as IndexedDB +import CDP.Domains.Input +import CDP.Domains.Input as Input +import CDP.Domains.Inspector +import CDP.Domains.Inspector as Inspector +import CDP.Domains.LayerTree +import CDP.Domains.LayerTree as LayerTree +import CDP.Domains.Log +import CDP.Domains.Log as Log +import CDP.Domains.Media +import CDP.Domains.Media as Media +import CDP.Domains.Memory +import CDP.Domains.Memory as Memory +import CDP.Domains.Overlay +import CDP.Domains.Overlay as Overlay +import CDP.Domains.Performance +import CDP.Domains.Performance as Performance +import CDP.Domains.PerformanceTimeline +import CDP.Domains.PerformanceTimeline as PerformanceTimeline +import CDP.Domains.Profiler +import CDP.Domains.Profiler as Profiler +import CDP.Domains.Runtime +import CDP.Domains.Runtime as Runtime +import CDP.Domains.ServiceWorker +import CDP.Domains.ServiceWorker as ServiceWorker +import CDP.Domains.Storage +import CDP.Domains.Storage as Storage +import CDP.Domains.SystemInfo +import CDP.Domains.SystemInfo as SystemInfo +import CDP.Domains.Tethering +import CDP.Domains.Tethering as Tethering +import CDP.Domains.Tracing +import CDP.Domains.Tracing as Tracing +import CDP.Domains.WebAudio +import CDP.Domains.WebAudio as WebAudio +import CDP.Domains.WebAuthn +import CDP.Domains.WebAuthn as WebAuthn + diff --git a/src/CDP/Domains/Accessibility.hs b/src/CDP/Domains/Accessibility.hs new file mode 100644 --- /dev/null +++ b/src/CDP/Domains/Accessibility.hs @@ -0,0 +1,725 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} + + +{- | += Accessibility + +-} + + +module CDP.Domains.Accessibility (module CDP.Domains.Accessibility) where + +import Control.Applicative ((<$>)) +import Control.Monad +import Control.Monad.Loops +import Control.Monad.Trans (liftIO) +import qualified Data.Map as M +import Data.Maybe +import Data.Functor.Identity +import Data.String +import qualified Data.Text as T +import qualified Data.List as List +import qualified Data.Text.IO as TI +import qualified Data.Vector as V +import Data.Aeson.Types (Parser(..)) +import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.:?), (.=), (.!=), (.:!)) +import qualified Data.Aeson as A +import qualified Network.HTTP.Simple as Http +import qualified Network.URI as Uri +import qualified Network.WebSockets as WS +import Control.Concurrent +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as Map +import Data.Proxy +import System.Random +import GHC.Generics +import Data.Char +import Data.Default + +import CDP.Internal.Utils + + +import CDP.Domains.DOMPageNetworkEmulationSecurity as DOMPageNetworkEmulationSecurity +import CDP.Domains.Runtime as Runtime + + +-- | Type 'Accessibility.AXNodeId'. +-- Unique accessibility node identifier. +type AccessibilityAXNodeId = T.Text + +-- | Type 'Accessibility.AXValueType'. +-- Enum of possible property types. +data AccessibilityAXValueType = AccessibilityAXValueTypeBoolean | AccessibilityAXValueTypeTristate | AccessibilityAXValueTypeBooleanOrUndefined | AccessibilityAXValueTypeIdref | AccessibilityAXValueTypeIdrefList | AccessibilityAXValueTypeInteger | AccessibilityAXValueTypeNode | AccessibilityAXValueTypeNodeList | AccessibilityAXValueTypeNumber | AccessibilityAXValueTypeString | AccessibilityAXValueTypeComputedString | AccessibilityAXValueTypeToken | AccessibilityAXValueTypeTokenList | AccessibilityAXValueTypeDomRelation | AccessibilityAXValueTypeRole | AccessibilityAXValueTypeInternalRole | AccessibilityAXValueTypeValueUndefined + deriving (Ord, Eq, Show, Read) +instance FromJSON AccessibilityAXValueType where + parseJSON = A.withText "AccessibilityAXValueType" $ \v -> case v of + "boolean" -> pure AccessibilityAXValueTypeBoolean + "tristate" -> pure AccessibilityAXValueTypeTristate + "booleanOrUndefined" -> pure AccessibilityAXValueTypeBooleanOrUndefined + "idref" -> pure AccessibilityAXValueTypeIdref + "idrefList" -> pure AccessibilityAXValueTypeIdrefList + "integer" -> pure AccessibilityAXValueTypeInteger + "node" -> pure AccessibilityAXValueTypeNode + "nodeList" -> pure AccessibilityAXValueTypeNodeList + "number" -> pure AccessibilityAXValueTypeNumber + "string" -> pure AccessibilityAXValueTypeString + "computedString" -> pure AccessibilityAXValueTypeComputedString + "token" -> pure AccessibilityAXValueTypeToken + "tokenList" -> pure AccessibilityAXValueTypeTokenList + "domRelation" -> pure AccessibilityAXValueTypeDomRelation + "role" -> pure AccessibilityAXValueTypeRole + "internalRole" -> pure AccessibilityAXValueTypeInternalRole + "valueUndefined" -> pure AccessibilityAXValueTypeValueUndefined + "_" -> fail "failed to parse AccessibilityAXValueType" +instance ToJSON AccessibilityAXValueType where + toJSON v = A.String $ case v of + AccessibilityAXValueTypeBoolean -> "boolean" + AccessibilityAXValueTypeTristate -> "tristate" + AccessibilityAXValueTypeBooleanOrUndefined -> "booleanOrUndefined" + AccessibilityAXValueTypeIdref -> "idref" + AccessibilityAXValueTypeIdrefList -> "idrefList" + AccessibilityAXValueTypeInteger -> "integer" + AccessibilityAXValueTypeNode -> "node" + AccessibilityAXValueTypeNodeList -> "nodeList" + AccessibilityAXValueTypeNumber -> "number" + AccessibilityAXValueTypeString -> "string" + AccessibilityAXValueTypeComputedString -> "computedString" + AccessibilityAXValueTypeToken -> "token" + AccessibilityAXValueTypeTokenList -> "tokenList" + AccessibilityAXValueTypeDomRelation -> "domRelation" + AccessibilityAXValueTypeRole -> "role" + AccessibilityAXValueTypeInternalRole -> "internalRole" + AccessibilityAXValueTypeValueUndefined -> "valueUndefined" + +-- | Type 'Accessibility.AXValueSourceType'. +-- Enum of possible property sources. +data AccessibilityAXValueSourceType = AccessibilityAXValueSourceTypeAttribute | AccessibilityAXValueSourceTypeImplicit | AccessibilityAXValueSourceTypeStyle | AccessibilityAXValueSourceTypeContents | AccessibilityAXValueSourceTypePlaceholder | AccessibilityAXValueSourceTypeRelatedElement + deriving (Ord, Eq, Show, Read) +instance FromJSON AccessibilityAXValueSourceType where + parseJSON = A.withText "AccessibilityAXValueSourceType" $ \v -> case v of + "attribute" -> pure AccessibilityAXValueSourceTypeAttribute + "implicit" -> pure AccessibilityAXValueSourceTypeImplicit + "style" -> pure AccessibilityAXValueSourceTypeStyle + "contents" -> pure AccessibilityAXValueSourceTypeContents + "placeholder" -> pure AccessibilityAXValueSourceTypePlaceholder + "relatedElement" -> pure AccessibilityAXValueSourceTypeRelatedElement + "_" -> fail "failed to parse AccessibilityAXValueSourceType" +instance ToJSON AccessibilityAXValueSourceType where + toJSON v = A.String $ case v of + AccessibilityAXValueSourceTypeAttribute -> "attribute" + AccessibilityAXValueSourceTypeImplicit -> "implicit" + AccessibilityAXValueSourceTypeStyle -> "style" + AccessibilityAXValueSourceTypeContents -> "contents" + AccessibilityAXValueSourceTypePlaceholder -> "placeholder" + AccessibilityAXValueSourceTypeRelatedElement -> "relatedElement" + +-- | Type 'Accessibility.AXValueNativeSourceType'. +-- Enum of possible native property sources (as a subtype of a particular AXValueSourceType). +data AccessibilityAXValueNativeSourceType = AccessibilityAXValueNativeSourceTypeDescription | AccessibilityAXValueNativeSourceTypeFigcaption | AccessibilityAXValueNativeSourceTypeLabel | AccessibilityAXValueNativeSourceTypeLabelfor | AccessibilityAXValueNativeSourceTypeLabelwrapped | AccessibilityAXValueNativeSourceTypeLegend | AccessibilityAXValueNativeSourceTypeRubyannotation | AccessibilityAXValueNativeSourceTypeTablecaption | AccessibilityAXValueNativeSourceTypeTitle | AccessibilityAXValueNativeSourceTypeOther + deriving (Ord, Eq, Show, Read) +instance FromJSON AccessibilityAXValueNativeSourceType where + parseJSON = A.withText "AccessibilityAXValueNativeSourceType" $ \v -> case v of + "description" -> pure AccessibilityAXValueNativeSourceTypeDescription + "figcaption" -> pure AccessibilityAXValueNativeSourceTypeFigcaption + "label" -> pure AccessibilityAXValueNativeSourceTypeLabel + "labelfor" -> pure AccessibilityAXValueNativeSourceTypeLabelfor + "labelwrapped" -> pure AccessibilityAXValueNativeSourceTypeLabelwrapped + "legend" -> pure AccessibilityAXValueNativeSourceTypeLegend + "rubyannotation" -> pure AccessibilityAXValueNativeSourceTypeRubyannotation + "tablecaption" -> pure AccessibilityAXValueNativeSourceTypeTablecaption + "title" -> pure AccessibilityAXValueNativeSourceTypeTitle + "other" -> pure AccessibilityAXValueNativeSourceTypeOther + "_" -> fail "failed to parse AccessibilityAXValueNativeSourceType" +instance ToJSON AccessibilityAXValueNativeSourceType where + toJSON v = A.String $ case v of + AccessibilityAXValueNativeSourceTypeDescription -> "description" + AccessibilityAXValueNativeSourceTypeFigcaption -> "figcaption" + AccessibilityAXValueNativeSourceTypeLabel -> "label" + AccessibilityAXValueNativeSourceTypeLabelfor -> "labelfor" + AccessibilityAXValueNativeSourceTypeLabelwrapped -> "labelwrapped" + AccessibilityAXValueNativeSourceTypeLegend -> "legend" + AccessibilityAXValueNativeSourceTypeRubyannotation -> "rubyannotation" + AccessibilityAXValueNativeSourceTypeTablecaption -> "tablecaption" + AccessibilityAXValueNativeSourceTypeTitle -> "title" + AccessibilityAXValueNativeSourceTypeOther -> "other" + +-- | Type 'Accessibility.AXValueSource'. +-- A single source for a computed AX property. +data AccessibilityAXValueSource = AccessibilityAXValueSource + { + -- | What type of source this is. + accessibilityAXValueSourceType :: AccessibilityAXValueSourceType, + -- | The value of this property source. + accessibilityAXValueSourceValue :: Maybe AccessibilityAXValue, + -- | The name of the relevant attribute, if any. + accessibilityAXValueSourceAttribute :: Maybe T.Text, + -- | The value of the relevant attribute, if any. + accessibilityAXValueSourceAttributeValue :: Maybe AccessibilityAXValue, + -- | Whether this source is superseded by a higher priority source. + accessibilityAXValueSourceSuperseded :: Maybe Bool, + -- | The native markup source for this value, e.g. a