@@ -1,17 +1,27 @@
11{-# LANGUAGE DataKinds #-}
22{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE MultiWayIf #-}
34{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE PatternGuards #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+
48module Obelisk.Command.Thunk
59 ( ThunkPtr (..)
610 , ThunkRev (..)
711 , ThunkSource (..)
12+ , ThunkData (..)
813 , GitHubSource (..)
914 , getLatestRev
1015 , updateThunkToLatest
1116 , createThunkWithLatest
1217 , nixBuildAttrWithCache
18+ , nixBuildThunkAttrWithCache
19+ , unpackThunk
20+ , packThunk
21+ , readThunk
1322 ) where
1423
24+import Control.Applicative
1525import Control.Exception
1626import Control.Monad
1727import Control.Monad.Except
@@ -22,8 +32,10 @@ import Data.Default
2232import Data.Foldable
2333import Data.Git.Ref (Ref)
2434import qualified Data.Git.Ref as Ref
35+import qualified Data.List as L
2536import Data.List.NonEmpty (NonEmpty (..))
2637import qualified Data.List.NonEmpty as NonEmpty
38+import qualified Data.Map as Map
2739import Data.Maybe
2840import Data.Monoid
2941import Data.Set (Set)
@@ -45,9 +57,20 @@ import System.Exit
4557import System.FilePath
4658import System.IO
4759import System.IO.Error
60+import System.IO.Temp
4861import System.Posix (modificationTime, getSymbolicLinkStatus)
4962import System.Process
5063
64+import Development.Placeholders
65+
66+--TODO: Support symlinked thunk data
67+data ThunkData
68+ = ThunkData_Packed ThunkPtr
69+ -- ^ Packed thunk
70+ | ThunkData_Checkout ThunkPtr
71+ -- ^ Checked out thunk that was unpacked from this pointer
72+ deriving (Show, Eq, Ord)
73+
5174-- | A reference to the exact data that a thunk should translate into
5275data ThunkPtr = ThunkPtr
5376 { _thunkPtr_rev :: ThunkRev
@@ -66,7 +89,10 @@ data ThunkRev = ThunkRev
6689
6790-- | A location from which a thunk's data can be retrieved
6891data ThunkSource
92+ -- | A source specialized for GitHub
6993 = ThunkSource_GitHub GitHubSource
94+ -- | A plain repo source
95+ | ThunkSource_Git GitSource
7096 deriving (Show, Eq, Ord)
7197
7298data GitHubSource = GitHubSource
@@ -77,18 +103,33 @@ data GitHubSource = GitHubSource
77103 }
78104 deriving (Show, Eq, Ord)
79105
106+data GitSource = GitSource
107+ { _gitSource_url :: URI
108+ --TODO: Is it ok to use the types from the GitHub api bindings?
109+ , _gitSource_branch :: Maybe (Name Branch)
110+ , _gitSource_fetchSubmodules :: Bool
111+ }
112+ deriving (Show, Eq, Ord)
113+
80114commitNameToRef :: Name Commit -> Ref
81115commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c
82116
83117getNixSha256ForUriUnpacked :: URI -> IO NixSha256
84118getNixSha256ForUriUnpacked uri = do
85− (_, out, _, p) <- runInteractiveProcess "nix-prefetch-url" --TODO: Make this package depend on nix-prefetch-url properly
119+ (_, out, err, p) <- runInteractiveProcess "nix-prefetch-url" --TODO: Make this package depend on nix-prefetch-url properly
86120 [ "--unpack"
87121 , "--type"
88122 , "sha256"
89123 , show uri
90124 ] Nothing Nothing
91− ExitSuccess <- waitForProcess p --TODO: Deal with errors here; usually they're HTTP errors
125+ --TODO: Deal with errors here; usually they're HTTP errors
126+ waitForProcess p >>= \case
127+ ExitSuccess -> return ()
128+ _ -> do
129+ hPutStrLn stdout =<< hGetContents out
130+ hPutStrLn stderr =<< hGetContents err
131+ --TODO: actual error
132+ fail $ "nix-prefetch-url"
92133 T.strip <$> T.hGetContents out
93134
94135-- | Get the latest revision available from the given source
@@ -112,29 +153,44 @@ getLatestRev = \case
112153 { _thunkRev_commit = commitNameToRef commit
113154 , _thunkRev_nixSha256 = nixSha256
114155 }
156+ ThunkSource_Git _s -> do
157+ $notImplemented
115158
159+--TODO: Pretty print these
116160data ReadThunkError
117161 = ReadThunkError_WrongContents (Set String) (Set String)
118162 | ReadThunkError_UnrecognizedLoader Text
119163 | ReadThunkError_UnparseablePtr LBS.ByteString
164+ deriving (Show)
165+
166+-- | Read a thunk and validate that it is only a thunk, either packed or unpacked.
167+-- If the thunk is packed and additional data is present, fail.
168+readThunk :: FilePath -> IO (Either ReadThunkError ThunkData)
169+readThunk thunkDir = do
170+ files <- listDirectory thunkDir
171+ case ".git" `elem` files of
172+ True -> fmap ThunkData_Checkout <$> readPackedThunk (thunkDir </> ".git" </> "obelisk" </> "orig-thunk")
173+ False -> fmap ThunkData_Packed <$> readPackedThunk thunkDir
120174
121−-- | Read a thunk and validate that it is only a thunk. If additional data is
122−-- present, fail.
123−readThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
124−readThunk thunkDir = runExceptT $ do
175+-- | Read a thunk and validate that it is exactly a packed thunk.
176+-- If additional data is present, fail.
177+readPackedThunk :: FilePath -> IO (Either ReadThunkError ThunkPtr)
178+readPackedThunk thunkDir = runExceptT $ do
125179 let thunkLoader = thunkDir </> "default.nix"
126180 githubJson = thunkDir </> "github.json"
127181 attrCache = thunkDir </> ".attr-cache"
128182 expectedContents = Set.fromList $
129183 [ githubJson
130184 , thunkLoader
131− , attrCache
185+ ]
186+ optionalContents = Set.fromList $
187+ [ attrCache
132188 ]
133189
134190 -- Ensure that there aren't any other files in the thunk
135191 -- NB: System.Directory.listDirectory returns the contents without the directory path
136192 files <- liftIO $ Set.fromList . fmap (thunkDir </>) <$> listDirectory thunkDir
137− let unexpectedContents = files `Set.difference` expectedContents
193+ let unexpectedContents = files `Set.difference` (expectedContents `Set.union` optionalContents)
138194 missingContents = expectedContents `Set.difference` files
139195 unless (Set.null unexpectedContents && Set.null missingContents) $ do
140196 throwError $ ReadThunkError_WrongContents unexpectedContents missingContents
@@ -145,26 +201,39 @@ readThunk thunkDir = runExceptT $ do
145201 throwError $ ReadThunkError_UnrecognizedLoader loader
146202
147203 txt <- liftIO $ LBS.readFile githubJson
148− let p v = do
149− owner <- v Aeson..: "owner"
150− repo <- v Aeson..: "repo"
204+ let parseThunk v = do
151205 rev <- v Aeson..: "rev"
152206 sha256 <- v Aeson..: "sha256"
153− branch <- v Aeson..:! "branch"
154− mPrivate <- v Aeson..:! "private"
207+ src <- parseGitHubSource v
208+ <|> parseGitSource v
155209 return $ ThunkPtr
156210 { _thunkPtr_rev = ThunkRev
157211 { _thunkRev_commit = Ref.fromHexString rev
158212 , _thunkRev_nixSha256 = sha256
159213 }
160− , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
161− { _gitHubSource_owner = owner
162− , _gitHubSource_repo = repo
163− , _gitHubSource_branch = branch
164− , _gitHubSource_private = fromMaybe False mPrivate
165− }
214+ , _thunkPtr_source = src
166215 }
167− case parseMaybe p =<< decode txt of
216+ parseGitHubSource v = do
217+ owner <- v Aeson..: "owner"
218+ repo <- v Aeson..: "repo"
219+ branch <- v Aeson..:! "branch"
220+ mPrivate <- v Aeson..:! "private"
221+ return $ ThunkSource_GitHub $ GitHubSource
222+ { _gitHubSource_owner = owner
223+ , _gitHubSource_repo = repo
224+ , _gitHubSource_branch = branch
225+ , _gitHubSource_private = fromMaybe False mPrivate
226+ }
227+ parseGitSource v = do
228+ Just url <- parseURI <$> v Aeson..: "url"
229+ branch <- v Aeson..:! "branch"
230+ fetchSubmodules <- v Aeson..: "fetchSubmodules"
231+ return $ ThunkSource_Git $ GitSource
232+ { _gitSource_url = url
233+ , _gitSource_branch = branch
234+ , _gitSource_fetchSubmodules = fetchSubmodules
235+ }
236+ case parseMaybe parseThunk =<< decode txt of
168237 Nothing -> throwError $ ReadThunkError_UnparseablePtr txt
169238 Just ptr -> return ptr
170239
@@ -177,39 +246,63 @@ overwriteThunk target thunk = do
177246 removeDirectoryRecursive target
178247 createThunk target thunk
179248
249+thunkPtrLoader :: ThunkPtr -> Text
250+thunkPtrLoader thunk = case _thunkPtr_source thunk of
251+ ThunkSource_GitHub _ -> NonEmpty.head gitHubStandaloneLoaders
252+ ThunkSource_Git _ -> NonEmpty.head plainGitStandaloneLoaders
253+
254+-- It's important that formatting be very consistent here, because
255+-- otherwise when people update thunks, their patches will be messy
256+encodeThunkPtrData :: ThunkPtr -> LBS.ByteString
257+encodeThunkPtrData (ThunkPtr rev src) = case src of
258+ ThunkSource_GitHub s -> encodePretty' githubCfg $ Aeson.object $ catMaybes
259+ [ Just $ "owner" .= _gitHubSource_owner s
260+ , Just $ "repo" .= _gitHubSource_repo s
261+ , case _gitHubSource_branch s of
262+ Just b -> Just $ "branch" .= b
263+ Nothing -> Nothing
264+ , if _gitHubSource_private s
265+ then Just $ "private" .= True
266+ else Nothing
267+ , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
268+ , Just $ "sha256" .= _thunkRev_nixSha256 rev
269+ ]
270+ ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes
271+ --TODO: Is this safe? read/show is jank for `URI`
272+ [ Just $ "url" .= show (_gitSource_url s)
273+ , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)
274+ , Just $ "sha256" .= _thunkRev_nixSha256 rev
275+ , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s
276+ ]
277+ where
278+ githubCfg = defConfig
279+ { confIndent = Spaces 2
280+ , confCompare = keyOrder
281+ [ "owner"
282+ , "repo"
283+ , "branch"
284+ , "private"
285+ , "rev"
286+ , "sha256"
287+ ] <> compare
288+ , confTrailingNewline = True
289+ }
290+ plainGitCfg = defConfig
291+ { confIndent = Spaces 2
292+ , confCompare = keyOrder
293+ [ "url"
294+ , "rev"
295+ , "sha256"
296+ , "fetchSubmodules"
297+ ] <> compare
298+ , confTrailingNewline = True
299+ }
300+
180301createThunk :: FilePath -> ThunkPtr -> IO ()
181302createThunk target thunk = do
182303 createDirectoryIfMissing True (target </> ".attr-cache")
183− case _thunkPtr_source thunk of
184− ThunkSource_GitHub s -> do
185− T.writeFile (target </> "default.nix") $ NonEmpty.head gitHubStandaloneLoaders
186− LBS.writeFile (target </> "github.json") $
187− -- It's important that formatting be very consistent here, because
188− -- otherwise when people update thunks, their patches will be messy
189− let cfg = defConfig
190− { confIndent = Spaces 2
191− , confCompare = keyOrder
192− [ "owner"
193− , "repo"
194− , "branch"
195− , "private"
196− , "rev"
197− , "sha256"
198− ] <> compare
199− , confTrailingNewline = True
200− }
201− in encodePretty' cfg $ Aeson.object $ catMaybes
202− [ Just $ "owner" .= _gitHubSource_owner s
203− , Just $ "repo" .= _gitHubSource_repo s
204− , case _gitHubSource_branch s of
205− Just b -> Just $ "branch" .= b
206− Nothing -> Nothing
207− , if _gitHubSource_private s
208− then Just $ "private" .= True
209− else Nothing
210− , Just $ "rev" .= Ref.toHexString (_thunkRev_commit (_thunkPtr_rev thunk))
211− , Just $ "sha256" .= _thunkRev_nixSha256 (_thunkPtr_rev thunk)
212− ]
304+ T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)
305+ LBS.writeFile (target </> "github.json") (encodeThunkPtrData thunk)
213306
214307createThunkWithLatest :: FilePath -> ThunkSource -> IO ()
215308createThunkWithLatest target s = do
@@ -221,10 +314,14 @@ createThunkWithLatest target s = do
221314
222315updateThunkToLatest :: FilePath -> IO ()
223316updateThunkToLatest target = do
224− Right ptr <- readThunk target
317+ (overwrite, ptr) <- readThunk target >>= \case
318+ Left err -> fail $ "thunk update: " <> show err
319+ Right c -> return $ case c of
320+ ThunkData_Packed t -> (target, t)
321+ ThunkData_Checkout t -> (target </> ".git" </> "obelisk", t)
225322 let src = _thunkPtr_source ptr
226323 rev <- getLatestRev src
227− overwriteThunk target $ ThunkPtr
324+ overwriteThunk overwrite $ ThunkPtr
228325 { _thunkPtr_source = src
229326 , _thunkPtr_rev = rev
230327 }
@@ -253,6 +350,17 @@ gitHubStandaloneLoaderV2 = T.unlines
253350 , "))"
254351 ]
255352
353+plainGitStandaloneLoaders :: NonEmpty Text
354+plainGitStandaloneLoaders =
355+ plainGitStandaloneLoaderV1 :|
356+ [
357+ ]
358+
359+plainGitStandaloneLoaderV1 :: Text
360+plainGitStandaloneLoaderV1 = T.unlines
361+ [ $notImplemented
362+ ]
363+
256364-- | Look for authentication info from the 'hub' command
257365getHubAuth
258366 :: Text -- ^ Domain name
@@ -283,6 +391,8 @@ nixBuildThunkAttrWithCache :: FilePath
283391-- the caching mechanism will fail as it merely measures the modification
284392-- time of the cache link and the expression to build.
285393nixBuildThunkAttrWithCache thunkDir attr = do
394+ --NB: Expects thunkDir to be normalised with no trailing path separator.
395+ --This should be guaranteed by the command argument parser.
286396 let cacheErrHandler e
287397 | isDoesNotExistError e = return Nothing -- expected from a cache miss
288398 | otherwise = hPutStrLn stderr (displayException e) >> return Nothing
@@ -317,11 +427,210 @@ nixBuildAttrWithCache :: FilePath
317427 -- ^ Symlink to cached or built nix output
318428nixBuildAttrWithCache exprPath attr = do
319429 readThunk exprPath >>= \case
320− Right _ -> nixBuildThunkAttrWithCache exprPath attr
321− Left _ -> nixBuild $ def
430+ -- Only packed thunks are cached. in particular, checkouts are not
431+ Right (ThunkData_Packed _) -> nixBuildThunkAttrWithCache exprPath attr
432+ _ -> nixBuild $ def
322433 { _nixBuildConfig_target = Target
323434 { _target_path = exprPath
324435 , _target_attr = Just attr
325436 }
326437 , _nixBuildConfig_outLink = OutLink_None
327438 }
439+
440+unpackThunk :: FilePath
441+ -> IO ()
442+unpackThunk thunkDir = readThunk thunkDir >>= \case
443+ Left err -> fail $ "thunk unpack: " <> show err
444+ --TODO: Overwrite option that rechecks out thunk; force option to do so even if working directory is dirty
445+ Right (ThunkData_Checkout _) -> fail "thunk unpack: thunk is already unpacked"
446+ Right (ThunkData_Packed tptr) -> case _thunkPtr_source tptr of
447+ ThunkSource_GitHub s | (thunkParent, thunkName) <- splitFileName thunkDir -> withTempDirectory thunkParent thunkName $ \tmpRepo -> do
448+ mauth <- getHubAuth "github.com"
449+ repoResult <- executeRequestMaybe mauth $ repositoryR (_gitHubSource_owner s) (_gitHubSource_repo s)
450+ githubURI <- either throwIO (return . repoSshUrl) repoResult >>= \case
451+ Nothing -> fail "Cannot determine clone URI for thunk source"
452+ Just c -> return $ T.unpack $ getUrl c
453+ callProcess "hub" --TODO: Depend on hub explicitly
454+ [ "clone"
455+ , "-n"
456+ , githubURI
457+ , tmpRepo
458+ ]
459+ let obGitDir = tmpRepo </> ".git" </> "obelisk"
460+ --If this directory already exists then something is weird and we should fail
461+ createDirectory obGitDir
462+ callProcess "cp"
463+ [ "-r"
464+ , "-T"
465+ , thunkDir </> "."
466+ , obGitDir </> "orig-thunk"
467+ ]
468+ let checkoutOptions = concat
469+ [ ["-C", tmpRepo]
470+ , pure "checkout"
471+ , maybe [] (\n -> ["-B", T.unpack (untagName n)]) (_gitHubSource_branch s)
472+ , pure $ Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr
473+ ]
474+ callProcess "hub" checkoutOptions
475+ callProcess "rm"
476+ [ "-r"
477+ , thunkDir
478+ ]
479+ callProcess "mv"
480+ [ "-T"
481+ , tmpRepo
482+ , thunkDir
483+ ]
484+ return ()
485+ ThunkSource_Git _s -> do
486+ $notImplemented
487+
488+--TODO: add force mode to pack even if changes are present
489+--TODO: add a rollback mode to pack to the original thunk
490+packThunk :: FilePath
491+ -> String
492+ -> IO ()
493+packThunk thunkDir upstream = readThunk thunkDir >>= \case
494+ Left err -> fail $ "thunk pack: " <> show err
495+ Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"
496+ Right (ThunkData_Checkout _) -> do
497+ --Check whether the working directory is clean
498+ statusOutput <- readProcess "hub"
499+ [ "-C", thunkDir
500+ , "status", "--porcelain", "--ignored" ] ""
501+ diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""
502+ case null statusOutput && null diffOutput of
503+ False -> do
504+ statusDebug <- readProcess "hub"
505+ [ "-C", thunkDir, "status", "--ignored" ] ""
506+ fail $ unlines $
507+ [ "thunk pack: thunk checkout contains unsaved modifications"
508+ , "git status:"
509+ ] ++ lines statusDebug
510+ True -> return ()
511+
512+ -- Check whether there are any stashes
513+ stashOutput <- readProcess "hub" [ "-C", thunkDir, "stash", "list" ] ""
514+ case null stashOutput of
515+ False -> do
516+ fail $ unlines $
517+ [ "thunk pack: thunk checkout has stashes"
518+ , "git stash list:"
519+ ] ++ lines stashOutput
520+ True -> return ()
521+
522+ --Check whether all local heads are pushed
523+ repoHeads <- lines <$> readProcess "hub"
524+ [ "-C", thunkDir
525+ , "for-each-ref", "--format=%(refname:short)", "refs/heads/"
526+ ] ""
527+ remotes <- lines <$> readProcess "hub" [ "-C", thunkDir, "remote" ] ""
528+ --Check that the upstream specified actually exists
529+ case L.find (== upstream) remotes of
530+ Nothing -> fail $ "thunk pack: upstream " <> upstream <> " does not exist"
531+ Just _ -> return ()
532+ -- iterate over cartesian product
533+ forM_ repoHeads $ \hd -> do
534+ [localRev] <- lines <$> readProcess "hub" [ "-C", thunkDir, "rev-parse", hd ] ""
535+ forM_ remotes $ \rm -> do
536+ --TODO: The error you get if a branch isn't pushed anywhere could be made more user friendly
537+ [remoteMergeRev] <- lines <$> readProcess "hub"
538+ [ "-C", thunkDir
539+ , "merge-base"
540+ , localRev
541+ , "remotes/" <> rm <> "/" <> hd
542+ ] ""
543+ case remoteMergeRev == localRev of
544+ False -> fail $ mconcat [ "thunk unpack: branch ", hd, " has not been pushed to ", rm ]
545+ True -> return ()
546+
547+ --We assume it's safe to pack the thunk at this point
548+ [remoteUri'] <- lines <$> readProcess "hub"
549+ [ "-C", thunkDir
550+ , "config", "--get", "remote." <> upstream <> ".url"
551+ ] ""
552+
553+ let uriParseFailure = "Could not identify git remote: " <> remoteUri'
554+ mRemoteUri = parseURIReference remoteUri'
555+ <|> parseSshShorthand remoteUri'
556+ thunkPtr <- case mRemoteUri of
557+ Nothing -> fail uriParseFailure
558+ Just remoteUri -> do
559+ refs <- fmap (refsToTuples . words) . lines <$> readProcess "hub"
560+ [ "-C"
561+ , thunkDir
562+ , "show-ref"
563+ , "--head" ] ""
564+ -- safe because exactly one hash is associated with HEAD
565+ let Just currentHead = fst <$> L.find ((== "HEAD") . snd) refs
566+ remoteHeads = Map.fromList $ catMaybes $ fmap
567+ (\(x,y) -> (,) x <$> L.stripPrefix ("refs/remotes/" <> upstream <> "/") y)
568+ refs
569+ localHeads = Map.fromList $ catMaybes $ fmap
570+ (\(x,y) -> (,) x <$> L.stripPrefix "refs/heads/" y)
571+ refs
572+ currentUpstreamBranch = Map.lookup currentHead remoteHeads
573+ <|> Map.lookup currentHead localHeads
574+ if
575+ | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch
576+ | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch
577+ callProcess "rm"
578+ [ "-rf"
579+ , thunkDir
580+ ]
581+ createThunk thunkDir thunkPtr
582+ return ()
583+ where
584+ refsToTuples [x, y] = (x, y)
585+ refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x
586+ isGithubThunk u
587+ | Just uriAuth <- uriAuthority u
588+ = case uriScheme u of
589+ "ssh:" -> uriAuth == URIAuth "git@" "github.com" ""
590+ s -> s `L.elem` [ "git:", "https:", "http:" ] -- "http:" just redirects to "https:"
591+ && uriRegName uriAuth == "github.com"
592+ | otherwise = False
593+ githubThunkPtr u commit' branch' = do
594+ ["/", owner', repo'] <- return $ splitDirectories (uriPath u)
595+ let owner = N (T.pack owner')
596+ repo = N (T.pack (dropExtension repo'))
597+ commit = N (T.pack commit')
598+ branch = N . T.pack <$> branch'
599+ mauth <- getHubAuth "github.com"
600+ repoResult <- executeRequestMaybe mauth $ repositoryR owner repo
601+ repoIsPrivate <- either throwIO (return . repoPrivate) repoResult
602+ archiveResult <- executeRequestMaybe mauth $
603+ archiveForR owner repo ArchiveFormatTarball (Just (untagName commit))
604+ archiveUri <- either throwIO return archiveResult
605+ hash <- getNixSha256ForUriUnpacked archiveUri
606+ return $ ThunkPtr
607+ { _thunkPtr_rev = ThunkRev
608+ { _thunkRev_commit = commitNameToRef commit
609+ , _thunkRev_nixSha256 = hash
610+ }
611+ , _thunkPtr_source = ThunkSource_GitHub $ GitHubSource
612+ { _gitHubSource_owner = owner
613+ , _gitHubSource_repo = repo
614+ , _gitHubSource_branch = branch
615+ , _gitHubSource_private = repoIsPrivate
616+ }
617+ }
618+ gitThunkPtr u _commit' _branch' = do
619+ case uriScheme u of
620+ "https:" -> return ()
621+ "git:" -> return ()
622+ _ -> fail $ "thunk pack: obelisk currently only supports https and git protocols for non-GitHub remotes"
623+ $notImplemented
624+ parseSshShorthand uri' = do
625+ -- This is what git does to check that the remote
626+ -- is not a local file path when parsing shorthand.
627+ -- Last referenced from here:
628+ -- https://github.com/git/git/blob/95ec6b1b3393eb6e26da40c565520a8db9796e9f/connect.c#L712
629+ let uri = T.pack uri'
630+ (authAndHostname, colonAndPath) = T.break (== ':') uri
631+ properUri = "ssh://" <> authAndHostname <> "/" <> T.drop 1 colonAndPath
632+ -- Shorthand is valid iff a colon is present and it occurs before the first slash
633+ -- This check is used to disambiguate a filepath containing a colon from shorthand
634+ guard $ isNothing (T.findIndex (=='/') authAndHostname)
635+ && not (T.null colonAndPath)
636+ parseURI $ T.unpack properUri