jpl-horizons-api (empty) → 0.1.0.0

raw patch · 6 files changed

+328/−0 lines, 6 filesdep +basedep +bytestringdep +jpl-horizons-apisetup-changed

Dependencies added: base, bytestring, jpl-horizons-api, megaparsec, req, scientific, text, time

Files

LICENSE +30/−0
README.md +3/−0
Setup.hs +2/−0
app/Main.hs +7/−0
jpl-horizons-api.cabal +51/−0
src/API/JPL/Horizons.hs +235/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Marco Zocca (c) 2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Marco Zocca nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,3 @@+# jpl-horizons-api++API bindings for the Nasa JPL Horizons service

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ app/Main.hs view

@@ -0,0 +1,7 @@+module Main where+++import Text.Printf (printf)++main :: IO ()+main = printf "hello"

+ jpl-horizons-api.cabal view

@@ -0,0 +1,51 @@+name:                jpl-horizons-api+version:             0.1.0.0+synopsis: Ephemerides for solar system objects from the JPL Horizons service+description: The JPL Horizons on-line solar system data and ephemeris computation service provides access to key solar system data and flexible production of highly accurate ephemerides for solar system objects (1,180,796 asteroids, 3,789 comets, 211 planetary satellites {includes satellites of Earth and dwarf planet Pluto}, 8 planets, the Sun, L1, L2, select spacecraft, and system barycenters). Horizons is provided by the Solar System Dynamics Group of the Jet Propulsion Laboratory.+homepage:            https://github.com/ocramz/jpl-horizons-api+license:             BSD3+license-file:        LICENSE+author:              Marco Zocca+maintainer:          example@example.com+copyright:           2022 Marco Zocca+category:            API Web Astronomy+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10+tested-with:         GHC == 7.10.2++library+  default-language:    Haskell2010+  ghc-options:         -Wall+  hs-source-dirs:      src+  exposed-modules:     API.JPL.Horizons+  build-depends:       base >= 4.7 && < 5+                     , bytestring+                     , megaparsec+                     , req+                     , scientific >= 0.3.7.0+                     , text >= 1.2.4.1+                     , time++executable jpl-horizons-api+  default-language:    Haskell2010+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  hs-source-dirs:      app+  main-is:             Main.hs+  build-depends:       base+                     , jpl-horizons-api++-- test-suite spec+--   default-language:    Haskell2010+--   ghc-options:         -Wall+--   type:                exitcode-stdio-1.0+--   hs-source-dirs:      test+--   main-is:             Spec.hs+--   build-depends:       base+--                      , jpl-horizons-api+--                      , hspec+--                      , QuickCheck++source-repository head+  type:     git+  location: https://github.com/ocramz/jpl-horizons-api

+ src/API/JPL/Horizons.hs view

@@ -0,0 +1,235 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-unused-imports -Wno-type-defaults -Wno-unused-top-binds #-}+-- | The JPL Horizons [1] on-line solar system data and ephemeris computation service provides access to key solar system data and flexible production of highly accurate ephemerides for solar system objects (1,180,796 asteroids, 3,789 comets, 211 planetary satellites {includes satellites of Earth and dwarf planet Pluto}, 8 planets, the Sun, L1, L2, select spacecraft, and system barycenters).+--+-- Horizons is provided by the Solar System Dynamics Group of the Jet Propulsion Laboratory.+--+-- 1) https://ssd.jpl.nasa.gov/horizons/+module API.JPL.Horizons (+  saveCsv,+  Body(..),+  -- -- * CSV export+  -- vecCsvBuilder, vecCsvHeader,+  -- bsbWriteFile+  ) where++import Control.Applicative (Alternative(..))+import Data.Functor (void)+import Data.Void+import Data.List (intercalate, intersperse)+import           System.IO (Handle, IOMode(..), withBinaryFile)+-- bytestring+import qualified Data.ByteString as BS (ByteString)+import qualified Data.ByteString.Builder as BSB (Builder, toLazyByteString, hPutBuilder, char8, string8)+import qualified Data.ByteString.Internal as BS (c2w)+import qualified Data.ByteString.Char8 as BS8 (pack)+-- megaparsec+import qualified Text.Megaparsec as P (Parsec, ParseErrorBundle, try, parse, parseTest, some, satisfy, between, skipManyTill, takeWhileP)+import qualified Text.Megaparsec.Error as P (errorBundlePretty)+import qualified Text.Megaparsec.Byte as PL (space1)+import qualified Text.Megaparsec.Byte.Lexer as PL (space, lexeme, symbol, skipLineComment, skipBlockComment, scientific, float, signed)+-- req+import Network.HTTP.Req (runReq, defaultHttpConfig, req, GET(..), Option, Url, Scheme(..), https, (/:), NoReqBody(..), bsResponse, responseBody, (=:) )+import Data.Text (Text)+-- scientific+import Data.Scientific (Scientific)+import Data.ByteString.Builder.Scientific (scientificBuilder)+-- time+import Data.Time.Calendar (Day, toGregorian, fromGregorian)++++bsbWriteFile :: FilePath -> BSB.Builder -> IO ()+bsbWriteFile = modifyFile WriteMode+modifyFile :: IOMode -> FilePath -> BSB.Builder -> IO ()+modifyFile mode f bld = withBinaryFile f mode (`BSB.hPutBuilder` bld)++-- | Make an API call, parse and save the results as CSV+saveCsv :: (Day, Day) -- ^ (first, last) day of observation+        -> Int -- ^ observation interval in minutes +        -> Body -- ^ solar system body+        -> FilePath -- ^ CSV directory path+        -> IO ()+saveCsv ds@(d0, d1) dt b fdir = do+  bsb <- get ds dt b+  let+    fpath = fdir <> "/" <> mconcat (intersperse "_" [show b, time d0, time d1]) <> ".csv"+  bsbWriteFile fpath bsb++-- | Run an API call+get :: (Day, Day) -> Int -> Body -> IO BSB.Builder+get ds dt b = do+  bs <- get0 $ opts ds dt b+  case P.parse vectors "" bs of+    Right vs -> pure $+                  vecCsvHeader <>+                  foldMap vecCsvBuilder vs+    Left e -> error $ P.errorBundlePretty e++get0 :: Option 'Https -> IO BS.ByteString+get0 os = runReq defaultHttpConfig $ do+  r <- req GET endpoint NoReqBody bsResponse os+  pure $ responseBody r++opts :: (Day, Day) -> Int -> Body -> Option 'Https+opts (d0, d1) dt b =+  "format" ==: "text" <>+  "make_ephem" ==: "yes" <>+  "ephem_type" ==: "vectors" <>+  "command" ==: bodyToCommand b <>+  "obj_data" ==: "no" <>+  "ref_system" ==: "icrf" <>+  "start_time" ==: time d0 <>+  "stop_time" ==: time d1 <>+  "step_size" ==: stepsizeMins dt++{-+    [id: 10]   Sun [Sol]+    [id:199]   Mercury+    [id:299]   Venus+    [id:399]   Earth+    [id:301]   Moon+    [id:499]   Mars+    [id:599]   Jupiter+    [id:699]   Saturn+    [id:799]   Uranus+    [id:899]   Neptune+-}++-- | Large bodies in the Solar System+data Body = Sun | Mercury | Venus | Earth | Moon | Mars | Jupiter | Saturn | Uranus | Neptune deriving (Eq, Show, Enum)++class IsBody c where+  bodyToCommand :: c -> String+instance IsBody Body where+  bodyToCommand = \case+    Sun -> "10"+    Mercury -> "199"+    Venus -> "299"+    Earth -> "399"+    Moon -> "301"+    Mars -> "499"+    Jupiter -> "599"+    Saturn -> "699"+    Uranus -> "799"+    Neptune -> "899"++stepsizeMins :: Int -> String+stepsizeMins m = show m <> "m"++time :: Day -> String+time d = intercalate "-" [show yy, show mm, show dd]+  where+    (yy, mm, dd) = toGregorian d++(==:) :: Text -> String -> Option 'Https+(==:) = (=:)++endpoint :: Url 'Https+endpoint = https "ssd.jpl.nasa.gov" /: "api" /: "horizons.api"++{-+2453736.500000000 = A.D. 2006-Jan-01 00:00:00.0000 TDB + X = 8.749529331045696E+07 Y = 7.604048145779434E+07 Z = 3.126488404274795E+06+ VX= 7.367178825395701E+00 VY= 1.398625134891928E+01 VZ= 7.299094429880579E-01+ LT= 3.868100505438247E+02 RG= 1.159627358316374E+08 RR= 1.474953828661886E+01+-}+++vectors :: Parser [Vec]+vectors = P.some header *> payload (P.some vec)++data Vec = Vec Scientific Scientific Scientific Scientific Scientific Scientific deriving (Show)++-- | CSV Header+vecCsvHeader :: BSB.Builder+vecCsvHeader = csvBuild BSB.string8 ["X", "Y", "Z", "VX", "VY", "VZ"]+-- | CSV data row+vecCsvBuilder :: Vec -> BSB.Builder+vecCsvBuilder (Vec v0x v0y v0z vvx vvy vvz) =+  csvBuild scientificBuilder [v0x, v0y, v0z, vvx, vvy, vvz]++csvBuild :: (t -> BSB.Builder) -> [t] -> BSB.Builder+csvBuild _ [] = mempty+csvBuild bfun (w:ws) = bfun w <> go ws+  where+    go (m:ms) = BSB.string8 "," <> bfun m <> go ms+    go [] = BSB.string8 "\n"+++-- | timestamp line e.g.+--+-- 2453736.500000000 = A.D. 2006-Jan-01 00:00:00.0000 TDB+timestamp :: Parser ()+timestamp = PL.float *> PL.space1 *> skipLine "= A.D."++vec :: Parser Vec+vec = do+  timestamp+  cx <- x <* PL.space1+  cy <- y <* PL.space1+  cz <- z <* PL.space1+  cvx <- vx <* PL.space1+  cvy <- vy <* PL.space1+  cvz <- vz <* PL.space1+  _ <- lt <* PL.space1+  _ <- rg <* PL.space1+  _ <- rr <* PL.space1+  pure $ Vec cx cy cz cvx cvy cvz++x, y, z, vx, vy, vz, lt, rg, rr :: Parser Scientific+x = vcomp "X"+y = vcomp "Y"+z = vcomp "Z"+vx = vcomp "VX"+vy = vcomp "VY"+vz = vcomp "VZ"+lt = vcomp "LT"+rg = vcomp "RG"+rr = vcomp "RR"++vcomp :: String -> Parser Scientific+vcomp vv = psymbol (BS8.pack vv) >> psymbol "=" >> scientific++scientific :: Parser Scientific+scientific = PL.signed space PL.scientific++payload :: Parser a -> Parser a+payload = P.between (psymbol "$$SOE") (psymbol "$$EOE")++-- payloadDelim :: Parser ()+-- payloadDelim = void $ psymbol "$$SOE"++header :: Parser ()+header = skipLine "Ephemeris" <|>+         skipLine "API" <|>+         skipLine "Target" <|>+         skipLine "Center" <|>+         skipLine "Output" <|>+         skipLine "EOP" <|>+         skipLine "Start" <|> skipLine "Stop" <|> skipLine "Step" <|> skipLine "Reference" <|> skipLine "JDTDB" <|>+         skipLine "X" <|> skipLine "Y" <|> skipLine "Z" <|>+         skipLine "VX" <|> skipLine "VY" <|> skipLine "VZ" <|>+         skipLine "LT" <|> skipLine "RG" <|> skipLine "RR"++skipLine :: String -> Parser ()+skipLine s = psymbol (BS8.pack s) *>+             void (P.takeWhileP (Just "") (\c -> c /= BS.c2w '\n')) *>+             void (psymbol ("\n"))++type Parser = P.Parsec Void BS.ByteString+type ParseErrorBundle = P.ParseErrorBundle BS.ByteString Void+++psymbol :: BS.ByteString -> Parser BS.ByteString+psymbol = PL.symbol space++space :: Parser ()+space = PL.space PL.space1 lineComment blockComment++lineComment, blockComment :: Parser ()+lineComment = PL.skipLineComment "****"++blockComment = PL.skipBlockComment "/**" "*/"