Merge pull request #40 from safareli/import

Make sure we only `import` directory

Author: safareli

src/SqlSquared/Parser.purs

@@ -24,7 +24,7 @@ import Data.Maybe (Maybe(..), fromMaybe, isJust)
 import Data.NonEmpty ((:|))
 import Data.Json.Extended as EJ
 import Data.Tuple (Tuple(..), uncurry)
-import Data.Path.Pathy as Pt
+import SqlSquared.Path as Pt
 import Data.String as S
 
 import SqlSquared.Constructors as C
@@ -412,7 +412,8 @@ import_
 import_ = asErrorMessage "import declaration" do
   _ ← keyword "import"
   s ← ident
-  pure $ Sig.Import s
+  path ← Pt.parseAnyDirPath P.fail s
+  pure $ Sig.Import path
 
 variable ∷ ∀ m t. SqlParser' m t
 variable = C.vari <$> variableString
@@ -571,13 +572,7 @@ parenRelation = do
 tableRelation ∷ ∀ m t. SqlParser m t (Sig.Relation t)
 tableRelation = do
   i ← ident
-  path ←
-    Pt.parsePath
-      (const $ P.fail "incorrect path")
-      (const $ P.fail "incorrect path")
-      (pure ∘ E.Right)
-      (pure ∘ E.Left)
-      i
+  path ← Pt.parseAnyFilePath P.fail i
   a ← PC.optionMaybe do
     _ ← keyword "as"
     ident

src/SqlSquared/Path.purs

@@ -0,0 +1,52 @@
+module SqlSquared.Path
+  ( AnyFilePath
+  , AnyDirPath
+  , parseAnyFilePath
+  , printAnyFilePath
+  , parseAnyDirPath
+  , printAnyDirPath
+  , genAnyFilePath
+  , genAnyDirPath
+  ) where
+
+import Prelude
+import Data.Either as E
+import Data.NonEmpty ((:|))
+import Data.Path.Pathy as Pt
+import Data.Path.Pathy.Gen as PtGen
+import Control.Monad.Gen as Gen
+import Control.Monad.Rec.Class (class MonadRec)
+import SqlSquared.Utils ((∘))
+
+type AnyDirPath = E.Either (Pt.AbsDir Pt.Unsandboxed) (Pt.RelDir Pt.Unsandboxed)
+type AnyFilePath = E.Either (Pt.AbsFile Pt.Unsandboxed) (Pt.RelFile Pt.Unsandboxed)
+
+printAnyDirPath :: AnyDirPath -> String
+printAnyDirPath = E.either Pt.unsafePrintPath Pt.unsafePrintPath
+
+parseAnyDirPath :: forall m. Applicative m => (forall a. String -> m a) -> String -> m AnyDirPath
+parseAnyDirPath fail = Pt.parsePath
+  (pure ∘ E.Right)
+  (pure ∘ E.Left)
+  (const $ fail "Expected a directory path")
+  (const $ fail "Expected a directory path")
+
+printAnyFilePath :: AnyFilePath -> String
+printAnyFilePath = E.either Pt.unsafePrintPath Pt.unsafePrintPath
+
+parseAnyFilePath :: forall m. Applicative m => (forall a. String -> m a) -> String -> m AnyFilePath
+parseAnyFilePath fail = Pt.parsePath
+  (const $ fail "Expected a file path")
+  (const $ fail "Expected a file path")
+  (pure ∘ E.Right)
+  (pure ∘ E.Left)
+
+genAnyFilePath :: forall m. Gen.MonadGen m => MonadRec m => m AnyFilePath
+genAnyFilePath = Gen.oneOf
+  $ (E.Left ∘ Pt.unsandbox <$> PtGen.genAbsFilePath)
+  :| [E.Right ∘ Pt.unsandbox <$> PtGen.genRelFilePath]
+
+genAnyDirPath :: forall m. Gen.MonadGen m => MonadRec m => m AnyDirPath
+genAnyDirPath = Gen.oneOf
+  $ (E.Left ∘ Pt.unsandbox <$> PtGen.genAbsDirPath)
+  :| [E.Right ∘ Pt.unsandbox <$> PtGen.genRelDirPath]

src/SqlSquared/Signature.purs

@@ -63,6 +63,7 @@ import Data.String as S
 import Data.String.Gen as GenS
 import Data.Traversable as T
 import Matryoshka (Algebra, CoalgebraM, class Corecursive, embed)
+import SqlSquared.Path as Pt
 import SqlSquared.Signature.BinaryOperator as BO
 import SqlSquared.Signature.Case as CS
 import SqlSquared.Signature.GroupBy as GB
@@ -139,7 +140,7 @@ data SqlF literal a
   | Parens a
 
 data SqlDeclF a
-  = Import String
+  = Import Pt.AnyDirPath
   | FunctionDecl (FunctionDeclR a)
 
 newtype SqlModuleF a =
@@ -502,8 +503,8 @@ printSqlDeclF = case _ of
     <> "(" <> F.intercalate ", " (append ":" ∘ ID.printIdent <$> args) <> ") BEGIN "
     <> body
     <> " END"
-  Import s →
-    "IMPORT " <> ID.printIdent s
+  Import path →
+    "IMPORT " <> ID.printIdent (Pt.printAnyDirPath path)
 
 printSqlQueryF ∷ Algebra SqlQueryF String
 printSqlQueryF (Query decls expr) = F.intercalate "; " $ L.snoc (printSqlDeclF <$> decls) expr
@@ -588,9 +589,9 @@ encodeJsonSqlDeclF = case _ of
     J.~> "args" J.:= args
     J.~> "body" J.:= body
     J.~> J.jsonEmptyObject
-  Import s →
+  Import path →
     "tag" J.:= "import"
-    J.~> "value" J.:= s
+    J.~> "value" J.:= Pt.printAnyDirPath path
     J.~> J.jsonEmptyObject
 
 encodeJsonSqlQueryF ∷ Algebra SqlQueryF J.Json
@@ -712,7 +713,8 @@ decodeJsonSqlDeclF = J.decodeJson >=> \obj → do
 
   decodeImport obj = do
     v ← obj J..? "value"
-    pure $ Import v
+    path ← Pt.parseAnyDirPath E.Left v
+    pure $ Import path
 
 decodeJsonSqlQueryF ∷ CoalgebraM (E.Either String) SqlQueryF J.Json
 decodeJsonSqlQueryF = J.decodeJson >=> \obj → do
@@ -761,16 +763,16 @@ genSqlF genLiteral n
     , genSelect n
     ]
 
-genSqlDeclF ∷ ∀ m. Gen.MonadGen m ⇒ CoalgebraM m SqlDeclF Int
+genSqlDeclF ∷ ∀ m. Gen.MonadGen m ⇒ MonadRec m ⇒ CoalgebraM m SqlDeclF Int
 genSqlDeclF n =
   Gen.oneOf $ genImport :|
     [ genFunctionDecl n
     ]
 
-genSqlQueryF ∷ ∀ m. Gen.MonadGen m ⇒ CoalgebraM m SqlQueryF Int
+genSqlQueryF ∷ ∀ m. Gen.MonadGen m ⇒ MonadRec m ⇒ CoalgebraM m SqlQueryF Int
 genSqlQueryF n = Query <$> genDecls n <*> pure n
 
-genSqlModuleF ∷ ∀ m. Gen.MonadGen m ⇒ CoalgebraM m SqlModuleF Int
+genSqlModuleF ∷ ∀ m. Gen.MonadGen m ⇒ MonadRec m ⇒ CoalgebraM m SqlModuleF Int
 genSqlModuleF n = Module <$> genDecls n
 
 genSetLiteral ∷ ∀ m l. Gen.MonadGen m ⇒ CoalgebraM m (SqlF l) Int
@@ -878,16 +880,16 @@ genFunctionDecl n = do
   args ← L.foldM foldFn L.Nil $ L.range 0 len
   pure $ FunctionDecl { ident, args, body: n - 1 }
 
-genImport ∷ ∀ m a. Gen.MonadGen m ⇒ m (SqlDeclF a)
-genImport = Import <$> genIdent
+genImport ∷ ∀ m a. Gen.MonadGen m ⇒ MonadRec m ⇒ m (SqlDeclF a)
+genImport = map Import Pt.genAnyDirPath
 
 genIdent ∷ ∀ m. Gen.MonadGen m ⇒ m String
 genIdent = do
   start ← Gen.elements $ "a" :| S.split (S.Pattern "") "bcdefghijklmnopqrstuvwxyz"
   body ← map (Int.toStringAs Int.hexadecimal) (Gen.chooseInt 0 100000)
   pure $ start <> body
 
-genDecls ∷ ∀ m. Gen.MonadGen m ⇒ Int → m (L.List (SqlDeclF Int))
+genDecls ∷ ∀ m. Gen.MonadGen m ⇒ MonadRec m ⇒ Int → m (L.List (SqlDeclF Int))
 genDecls n = do
   let
     foldFn acc _ = do

src/SqlSquared/Signature/Relation.purs

@@ -6,20 +6,18 @@ import Control.Monad.Gen as Gen
 import Control.Monad.Gen.Common as GenC
 import Control.Monad.Rec.Class (class MonadRec)
 import Data.Argonaut as J
-import Data.Either (Either(..), either)
+import Data.Either (Either(..))
 import Data.Foldable as F
-import Data.Int as Int
 import Data.Maybe (Maybe)
 import Data.Monoid (mempty)
 import Data.NonEmpty ((:|))
-import Data.Path.Pathy as Pt
 import Data.String.Gen as GenS
 import Data.Traversable as T
 import Matryoshka (Algebra, CoalgebraM)
+import SqlSquared.Path as Pt
 import SqlSquared.Signature.Ident as ID
 import SqlSquared.Signature.JoinType as JT
 import SqlSquared.Utils ((∘))
-
 type JoinRelR a =
   { left ∷ Relation a
   , right ∷ Relation a
@@ -38,7 +36,7 @@ type VariRelR =
   }
 
 type TableRelR =
-  { path ∷ Either (Pt.AbsFile Pt.Unsandboxed) (Pt.RelFile Pt.Unsandboxed)
+  { path ∷ Pt.AnyFilePath
   , alias ∷ Maybe String
   }
 
@@ -91,7 +89,7 @@ printRelation = case _ of
     ":" <> ID.printIdent vari <> F.foldMap (\a → " AS " <> ID.printIdent a) alias
   TableRelation { path, alias } →
     "`"
-    <> either Pt.unsafePrintPath Pt.unsafePrintPath path
+    <> Pt.printAnyFilePath path
     <> "`"
     <> F.foldMap (\x → " AS " <> ID.printIdent x) alias
   JoinRelation { left, right, joinType, clause } →
@@ -117,7 +115,7 @@ encodeJsonRelation = case _ of
     J.~> J.jsonEmptyObject
   TableRelation { path, alias } →
     "tag" J.:= "table relation"
-    J.~> "path" J.:= either Pt.unsafePrintPath Pt.unsafePrintPath path
+    J.~> "path" J.:= Pt.printAnyFilePath path
     J.~> "alias" J.:= alias
     J.~> J.jsonEmptyObject
   JoinRelation { left, right, joinType, clause } →
@@ -150,13 +148,7 @@ decodeJsonRelation = J.decodeJson >=> \obj → do
 
   decodeTableRelation obj = do
     pathStr ← obj J..? "path"
-    path ←
-      Pt.parsePath
-        (const $ Left "incorrect path")
-        (const $ Left "incorrect path")
-        (Right ∘ Right)
-        (Right ∘ Left)
-        pathStr
+    path ← Pt.parseAnyFilePath Left pathStr
     alias ← obj J..? "alias"
     pure $ TableRelation { path, alias }
 
@@ -186,13 +178,7 @@ genRelation n =
     alias ← GenC.genMaybe GenS.genUnicodeString
     pure $ VariRelation { vari, alias }
   genTable = do
-    let
-      pathPart =
-        map (Int.toStringAs Int.hexadecimal) (Gen.chooseInt 0 100000)
-    dirs ← map Pt.dir <$> Gen.resize (const n) (Gen.unfoldable pathPart ∷ m (Array String))
-    fileName ← map Pt.file pathPart
-    let
-      path = Left $ Pt.rootDir Pt.</> F.foldl (\a b → b Pt.</> a) fileName dirs
+    path ← Pt.genAnyFilePath
     alias ← GenC.genMaybe GenS.genUnicodeString
     pure $ TableRelation { path, alias }
   genExpr = do

test/src/Parse.purs

@@ -40,6 +40,25 @@ parseFail s =
     E.Left err → pure unit
     E.Right (sql ∷ SqlQuery) → Assert.assert s false
 
+parseFailWith ∷ ∀ e. String → String → TestSuite (testOutput ∷ Console.TESTOUTPUT | e)
+parseFailWith s err =
+  test "parse/failWith"
+  case parseQuery s of
+    E.Left err' →
+      if show err' == err
+        then pure unit
+        else Assert.assert
+          ("expected query:" <> s <>
+          "\n\n  to fail input error:   " <> err <>
+          "\n\n  but instead fot error: " <> show err')
+          false
+    E.Right (sql ∷ SqlQuery) →
+      Assert.assert
+        ("expected to fail with:" <> err <>
+        "\n\tbut input query:" <> s <>
+        "\n\twas parsed as:" <> printQuery sql)
+        false
+
 testSuite ∷ ∀ e. TestSuite (testOutput ∷ Console.TESTOUTPUT | e)
 testSuite = suite "parsers" do
   testSuite1
@@ -51,6 +70,14 @@ testSuite = suite "parsers" do
 
 testSuite1 ∷ ∀ e. TestSuite (testOutput ∷ Console.TESTOUTPUT | e)
 testSuite1 = do
+  parseFailWith """
+    import `/path/To/Your/File/myModule`; SELECT id("HELLO")
+  """ "(ParseError \"Expected a directory path\" (Position { line: 2, column: 12 }))"
+
+  parseSucc """
+    import `/path/To/Your/File/myModule/`; SELECT id("HELLO")
+  """
+
   parseSucc """
     a := 1; SELECT * FROM `/test`
   """
@@ -157,6 +184,10 @@ testSuite1 = do
   """
 
   parseSucc """
+    import `foo/`; select * from `/test`
+  """
+
+  parseFail """
     import foo; select * from `/test`
   """