module Gifcurry
( gif
, GifParams(..)
, defaultGifParams
, defaultFontChoice
, gifParamsValid
, versionNumber
, getVideoDurationInSeconds
, getOutputFileWithExtension
, getVideoWidthAndHeight
, findOrCreateTemporaryDirectory
)
where
import System.Process
import System.IO.Temp
import System.Directory
import System.FilePath
import Text.Read
import Data.Maybe
import Data.List
import Data.Text
import Data.Either
import Text.Printf
import Control.Exception
import Control.Monad
data GifParams =
GifParams
{ inputFile :: String
, outputFile :: String
, saveAsVideo :: Bool
, startTime :: Float
, durationTime :: Float
, widthSize :: Int
, qualityPercent :: Float
, fontChoice :: String
, topText :: String
, bottomText :: String
, leftCrop :: Float
, rightCrop :: Float
, topCrop :: Float
, bottomCrop :: Float
}
deriving (Show, Read)
versionNumber :: String
versionNumber = "3.0.0.1"
defaultGifParams :: GifParams
defaultGifParams =
GifParams
{ inputFile = ""
, outputFile = ""
, saveAsVideo = False
, startTime = 0.0
, durationTime = 1.0
, widthSize = 500
, qualityPercent = 100.0
, fontChoice = defaultFontChoice
, topText = ""
, bottomText = ""
, leftCrop = 0.0
, rightCrop = 0.0
, topCrop = 0.0
, bottomCrop = 0.0
}
gif :: GifParams -> IO (Either IOError String)
gif
gifParams@GifParams { saveAsVideo }
= do
temporaryDirectory <- findOrCreateTemporaryDirectory
withTempDirectory temporaryDirectory "gifcurry-frames" $ \ tempDir ->
handleFrameExtraction tempDir
>>= handleFrameMerge tempDir
>>= handleGifToVideoConversion
where
handleFrameExtraction :: String -> IO (Either IOError Float)
handleFrameExtraction tempDir = do
printGifParams gifParams
validParams <- gifParamsValid gifParams
if validParams
then do
frameRate <-
validateAndAdjustFrameRate gifParams <$>
getVideoAverageFrameRateInSeconds gifParams
result <- extractFrames gifParams tempDir frameRate
case result of
Left x -> do
putStrLn "[ERROR] Something went wrong with FFmpeg."
return $ Left x
Right _ -> return $ Right frameRate
else return $ Left $ userError "Invalid params."
handleFrameMerge :: String -> Either IOError Float -> IO (Either IOError String)
handleFrameMerge tempDir (Right frameRate) = do
fontMatch <- getFontMatch gifParams
let gifParams' = gifParams { fontChoice = fontMatch }
result <- mergeFramesIntoGif gifParams' tempDir frameRate
case result of
Left x -> do
putStrLn "[ERROR] Something went wrong with ImageMagick."
return $ Left x
Right gifFilePath -> return $ Right gifFilePath
handleFrameMerge _ (Left x) = return $ Left x
handleGifToVideoConversion :: Either IOError String -> IO (Either IOError String)
handleGifToVideoConversion (Right gifFilePath) =
if saveAsVideo
then do
result <- convertGifToVideo gifParams gifFilePath
case result of
Left x -> do
putStrLn "[ERROR] Something went wrong with FFmpeg."
return $ Left x
Right outputFileWithExtension -> do
putStrLn "[INFO] All done."
return $ Right outputFileWithExtension
else do
putStrLn "[INFO] All done."
return $ Right gifFilePath
handleGifToVideoConversion result@(Left _) = return result
getFontMatch :: GifParams -> IO String
getFontMatch GifParams { topText = "", bottomText = "" } = defaultFontMatch
getFontMatch gifParams' = do
fontNames <- getListOfFontNames
let match = bestFontNameMatch (fontChoiceOrDefault gifParams') fontNames
putStrLn $ "[INFO] Your font choice matched to \"" ++ match ++ "\"."
return match
defaultFontMatch :: IO String
defaultFontMatch = putStrLn "[INFO] Using the default font." >> return defaultFontChoice
gifParamsValid :: GifParams -> IO Bool
gifParamsValid
GifParams
{ inputFile
, outputFile
, startTime
, durationTime
, widthSize
, qualityPercent
, leftCrop
, rightCrop
, topCrop
, bottomCrop
}
= do
inputFileExists <-
case Prelude.length inputFile of
0 -> return False
_ -> doesFileExist inputFile
let widthSize' = fromIntegral widthSize :: Float
let outputFileValid = not $ Data.Text.null $ Data.Text.strip $ Data.Text.pack outputFile
let startTimeValid = startTime >= 0.0
let durationTimeValid = durationTime > 0.0
let widthSizeValid = widthSize >= 1
let qualityPercentValid = qualityPercent >= 1.0 && qualityPercent <= 100.0
let leftCropValid = cropValid leftCrop
let rightCropValid = cropValid rightCrop
let topCropValid = cropValid topCrop
let bottomCropValid = cropValid bottomCrop
let leftRightCropValid = cropValid (leftCrop + rightCrop)
let topBottomCropValid = cropValid (topCrop + bottomCrop)
let widthLeftRightCropSizeValid =
(widthSize' (widthSize' * (leftCrop / 100.0)) (widthSize' * (rightCrop / 100.0))) >= 1.0
unless inputFileExists $ printError "Input video file does not exist."
unless outputFileValid $ printInvalid "Output File"
unless startTimeValid $ printInvalid "Start Time"
unless durationTimeValid $ printInvalid "Duration Time"
unless widthSizeValid $ printInvalid "Width Size"
unless qualityPercentValid $ printInvalid "Quality Percent"
unless leftCropValid $ printInvalid "Left Crop"
unless rightCropValid $ printInvalid "Right Crop"
unless topCropValid $ printInvalid "Top Crop"
unless bottomCropValid $ printInvalid "Bottom Crop"
unless leftRightCropValid $ printInvalid "Left and Right Crop"
unless topBottomCropValid $ printInvalid "Top and Bottom Crop"
unless widthLeftRightCropSizeValid $ printError "Width Size too small with Left and Right Crop."
let valid =
inputFileExists
&& outputFileValid
&& startTimeValid
&& durationTimeValid
&& widthSizeValid
&& qualityPercentValid
&& leftCropValid
&& rightCropValid
&& topCropValid
&& bottomCropValid
&& widthLeftRightCropSizeValid
return valid
where
cropValid :: Float -> Bool
cropValid c = c >= 0.0 && c <= 100.0
printInvalid :: String -> IO ()
printInvalid s = printError $ s ++ " is invalid."
printError :: String -> IO ()
printError s = putStrLn $ "[ERROR] " ++ s
getVideoDurationInSeconds :: GifParams -> IO (Maybe Float)
getVideoDurationInSeconds GifParams { inputFile } = do
streamResult <- result <$> tryFfprobe streamParams
if streamResult <= 0.0
then do
containerResult <- result <$> tryFfprobe containerParams
if containerResult <= 0.0
then return Nothing
else return $ Just containerResult
else return $ Just streamResult
where
result :: Either IOError String -> Float
result (Left _) = 0.0
result (Right durationString) = fromMaybe 0.0 (readMaybe durationString :: Maybe Float)
streamParams :: [String]
streamParams =
[ "-i"
, inputFile
, "-v"
, "error"
, "-select_streams"
, "v:0"
, "-show_entries"
, "stream=duration"
, "-of"
, "default=noprint_wrappers=1:nokey=1"
]
containerParams :: [String]
containerParams =
[ "-i"
, inputFile
, "-v"
, "error"
, "-show_entries"
, "format=duration"
, "-of"
, "default=noprint_wrappers=1:nokey=1"
]
getVideoWidthAndHeight :: GifParams -> IO (Maybe (Float, Float))
getVideoWidthAndHeight GifParams { inputFile } = tryFfprobe params >>= result
where
result :: Either IOError String -> IO (Maybe (Float, Float))
result (Left _) = return Nothing
result (Right widthHeightString) =
case (maybeWidth, maybeHeight) of
(Just width, Just height) ->
if width >= 0.0 && height > 0.0
then return $ Just (width, height)
else return Nothing
_ -> return Nothing
where
maybeWidth :: Maybe Float
maybeWidth =
case widthHeightTexts of
(widthText:_) -> maybeFloat widthText
_ -> Nothing
maybeHeight :: Maybe Float
maybeHeight =
case widthHeightTexts of
(_:heightText:_) -> maybeFloat heightText
_ -> Nothing
maybeFloat :: Text -> Maybe Float
maybeFloat t = readMaybe (Data.Text.unpack t) :: Maybe Float
widthHeightTexts :: [Text]
widthHeightTexts =
(Data.List.map Data.Text.strip . Data.Text.lines) widthHeightText
widthHeightText :: Text
widthHeightText =
Data.Text.strip $ Data.Text.pack widthHeightString
params :: [String]
params =
[ "-i"
, inputFile
, "-v"
, "error"
, "-select_streams"
, "v:0"
, "-show_entries"
, "stream=width,height"
, "-of"
, "default=noprint_wrappers=1:nokey=1"
]
findOrCreateTemporaryDirectory :: IO FilePath
findOrCreateTemporaryDirectory = do
filePath <- System.Directory.getXdgDirectory System.Directory.XdgCache "gifcurry"
System.Directory.createDirectoryIfMissing True filePath
return filePath
getOutputFileWithExtension :: GifParams -> String
getOutputFileWithExtension GifParams { outputFile, saveAsVideo } =
outputFile
++ "."
++ (if saveAsVideo then videoExtension else gifExtension)
defaultFontChoice :: String
defaultFontChoice = "sans"
gifOutputFile :: String -> String
gifOutputFile outputFile =
getOutputFileWithExtension $
defaultGifParams { outputFile = outputFile, saveAsVideo = False }
videoOutputFile :: String -> String
videoOutputFile outputFile =
getOutputFileWithExtension $
defaultGifParams { outputFile = outputFile, saveAsVideo = True }
defaultFrameRate :: Float
defaultFrameRate = 15.0
validateAndAdjustFrameRate :: GifParams -> Maybe Float -> Float
validateAndAdjustFrameRate gifParams =
frameRateBasedOnQualityPercent gifParams . maybeFrameRateOrDefaultFrameRate
maybeFrameRateOrDefaultFrameRate :: Maybe Float -> Float
maybeFrameRateOrDefaultFrameRate (Just frameRate) =
if frameRate <= defaultFrameRate then defaultFrameRate else frameRate
maybeFrameRateOrDefaultFrameRate Nothing = defaultFrameRate
frameRateBasedOnQualityPercent :: GifParams -> Float -> Float
frameRateBasedOnQualityPercent GifParams { qualityPercent } frameRate =
if result <= defaultFrameRate then defaultFrameRate else result
where
result :: Float
result = frameRate * (qualityPercent / 100.0)
getVideoAverageFrameRateInSeconds :: GifParams -> IO (Maybe Float)
getVideoAverageFrameRateInSeconds GifParams { inputFile } = tryFfprobe params >>= result
where
result :: Either IOError String -> IO (Maybe Float)
result (Left _) = return Nothing
result (Right avgFrameRateString) = return $ processString avgFrameRateString
where
processString :: String -> Maybe Float
processString =
divideMaybeFloats . textsToMaybeFloats . filterNullTexts . splitText . cleanString
cleanString :: String -> Text
cleanString = Data.Text.strip . Data.Text.pack
splitText :: Text -> [Text]
splitText = Data.Text.split (== '/')
filterNullTexts :: [Text] -> [Text]
filterNullTexts = Data.List.filter (not . Data.Text.null)
textsToMaybeFloats :: [Text] -> [Maybe Float]
textsToMaybeFloats =
Data.List.filter isJust
. Data.List.map (\ s -> readMaybe (Data.Text.unpack s) :: Maybe Float)
divideMaybeFloats :: [Maybe Float] -> Maybe Float
divideMaybeFloats (Just n:Just d:_) =
if d <= 0 || n <= 0 then Nothing else Just $ n / d
divideMaybeFloats _ = Nothing
params :: [String]
params =
[ "-v"
, "error"
, "-select_streams"
, "v:0"
, "-show_entries"
, "stream=avg_frame_rate"
, "-of"
, "default=noprint_wrappers=1:nokey=1"
, inputFile
]
tryFfprobe :: [String] -> IO (Either IOError String)
tryFfprobe params = try $ readProcess "ffprobe" params []
printGifParams :: GifParams -> IO ()
printGifParams
gifParams@GifParams
{ inputFile
, saveAsVideo
, startTime
, durationTime
, widthSize
, qualityPercent
, fontChoice
, topText
, bottomText
, leftCrop
, rightCrop
, topCrop
, bottomCrop
}
=
putStrLn $
Prelude.unlines
[ "[INFO] Here are your settings."
, ""
, "FILE IO:"
, ""
, "Input File: " ++ inputFile
, "Output File: " ++ getOutputFileWithExtension gifParams
, "Save As Video: " ++ if saveAsVideo then "Yes" else "No"
, ""
, "TIME:"
, ""
, "Start Second: " ++ printFloat startTime
, "Duration Time: " ++ printFloat durationTime ++ " seconds"
, ""
, "OUTPUT FILE SIZE:"
, ""
, "Width Size: " ++ show widthSize ++ "px"
, "Quality Percent: " ++ show (qualityPercentClamp qualityPercent) ++ "%"
, ""
, "TEXT:"
, ""
, "Font Choice: " ++ fontChoice
, "Top Text: " ++ topText
, "Bottom Text: " ++ bottomText
, ""
, "CROP:"
, ""
, "Left Crop: " ++ printFloat leftCrop
, "Right crop: " ++ printFloat rightCrop
, "Top Crop: " ++ printFloat topCrop
, "Bottom Crop: " ++ printFloat bottomCrop
]
where
printFloat :: Float -> String
printFloat = printf "%.3f"
frameFileExtension :: String
frameFileExtension = "png"
gifExtension :: String
gifExtension = "gif"
videoExtension :: String
videoExtension = "mp4"
extractFrames :: GifParams -> String -> Float -> IO (Either IOError String)
extractFrames
GifParams
{ inputFile
, startTime
, durationTime
, widthSize
, leftCrop
, rightCrop
, topCrop
, bottomCrop
}
tempDir
frameRate
= do
putStrLn $ "[INFO] Writing the temporary frames to: " ++ tempDir
try $ readProcess "ffmpeg" params []
where
startTime' :: String
startTime' = printf "%.3f" startTime
durationTime' :: String
durationTime' = printf "%.3f" durationTime
widthSize' :: String
widthSize' = show widthSize
frameRate' :: String
frameRate' = show $ maybeFrameRateOrDefaultFrameRate (Just frameRate)
params :: [String]
params =
[ "-nostats"
, "-loglevel"
, "fatal"
, "-an"
, "-ss"
, startTime'
, "-i"
, inputFile
, "-t"
, durationTime'
, "-r"
, frameRate'
, "-q:v"
, "31"
, "-vf"
, "scale="
++ widthSize'
++ ":-1"
++",crop=w=iw*(1-"
++ show ((leftCrop + rightCrop) / 100.0)
++ "):h=ih*(1-"
++ show ((topCrop + bottomCrop) / 100.0)
++ "):x=iw*"
++ show (leftCrop / 100.0)
++ ":y=ih*"
++ show (topCrop / 100.0)
++ ":exact=1"
, "-f"
, "image2"
, tempDir ++ "/%010d." ++ frameFileExtension
]
mergeFramesIntoGif :: GifParams -> String -> Float -> IO (Either IOError String)
mergeFramesIntoGif
GifParams
{ outputFile
, saveAsVideo
, qualityPercent
, fontChoice
, topText
, bottomText
}
tempDir
frameRate
= do
maybeWidthHeight <-
maybeGetFirstFrameFilePath tempDir >>=
maybeGetFirstFrameWidthHeight
let frameRate' = maybeFrameRateOrDefaultFrameRate (Just frameRate)
let delay = show $ 100.0 / frameRate'
let outputFile' =
if saveAsVideo
then tempDir ++ "/finished-result.gif"
else gifOutputFile outputFile
let params =
[ "-quiet"
, "-delay"
, delay
, tempDir ++ "/*." ++ frameFileExtension
]
++ annotate fontChoice maybeWidthHeight topText "north"
++ annotate fontChoice maybeWidthHeight bottomText "south"
++ [ "+dither"
, "-colors"
, show $ numberOfColors qualityPercent
, "-fuzz"
, "2%"
, "-layers"
, "OptimizeFrame"
, "-layers"
, "OptimizeTransparency"
, "-loop"
, "0"
, "+map"
, outputFile'
]
putStrLn $ "[INFO] Saving your GIF to: " ++ outputFile'
result <- try $ readProcess "convert" params []
if isLeft result
then return result
else return $ Right outputFile'
convertGifToVideo :: GifParams -> String -> IO (Either IOError String)
convertGifToVideo GifParams { outputFile } gifFilePath = do
let outputFile' = videoOutputFile outputFile
let params =
[ "-nostats"
, "-loglevel"
, "fatal"
, "-y"
, "-i"
, gifFilePath
, "-movflags"
, "faststart"
, "-pix_fmt"
, "yuv420p"
, "-vf"
, "scale=trunc(iw/2)*2:trunc(ih/2)*2"
, outputFile'
]
putStrLn $ "[INFO] Saving your video to: " ++ outputFile'
result <- try $ readProcess "ffmpeg" params []
if isLeft result
then return result
else return (Right outputFile')
qualityPercentClamp :: Float -> Float
qualityPercentClamp qualityPercent
| qualityPercent > 100.0 = 100.0
| qualityPercent < 0.0 = 1.0
| otherwise = qualityPercent
numberOfColors :: Float -> Int
numberOfColors qualityPercent
| qualityPercentClamp qualityPercent <= 1.0 = 2
| qualityPercentClamp qualityPercent >= 100.0 = floor maxColors
| otherwise = truncate $ (qualityPercent / 100.0) * maxColors
where
maxColors :: Float
maxColors = 256.0
annotate :: String -> Maybe (Int, Int) -> String -> String -> [String]
annotate fontChoiceArg maybeWidthHeight text topBottom =
[ "-gravity"
, topBottom
]
++ fontSetting fontChoiceArg
++ [ "-stroke"
, "#000C"
, "-strokewidth"
, "10"
, "-density"
, "96"
, "-pointsize"
, pointsize
, "-annotate"
, "+0+10"
, text
, "-stroke"
, "none"
, "-fill"
, "white"
, "-density"
, "96"
, "-pointsize"
, pointsize
, "-annotate"
, "+0+10"
, text
]
where
pointsize :: String
pointsize = show $ pointSize maybeWidthHeight text
pointSize :: Maybe (Int, Int) -> String -> Int
pointSize Nothing _ = 0
pointSize (Just (width, height)) text
| width <= 0 || height <= 0 = 0
| textLength <= 0 = 0
| otherwise = Prelude.minimum [widthLTHeight, widthGTEHeight]
where
textLength :: Int
textLength = Prelude.length text
width' :: Double
width' = fromIntegral width
height' :: Double
height' = fromIntegral height
textLength' :: Double
textLength' = fromIntegral textLength
widthLTHeight :: Int
widthLTHeight = truncate $ ((width' * (5.0 / 7.0)) / textLength') * (96.0 / 71.0)
widthGTEHeight :: Int
widthGTEHeight = truncate $ height' * (1.0 / 5.0)
fontSetting :: String -> [String]
fontSetting "" = []
fontSetting font = ["-font", font]
bestFontNameMatch :: String -> [Text] -> String
bestFontNameMatch _ [] = "default"
bestFontNameMatch _ [""] = "default"
bestFontNameMatch query fontNames = Data.Text.unpack $ bestMatch $ maximumMatch $ Data.Text.pack query
where
bestMatch :: (Int, Text) -> Text
bestMatch (s, f) = if s <= 0 then "default" else f
maximumMatch :: Text -> (Int, Text)
maximumMatch query' =
maximumBy (\ (ls, _) (rs, _) -> if ls >= rs then GT else LT) $
Prelude.map (\ fontName -> (score query' (Data.Text.toLower fontName), fontName)) fontNames
score :: Text -> Text -> Int
score query' fontName = sum $ Prelude.map tokenScore (queryTokens query')
where
queryTokens :: Text -> [Text]
queryTokens = Prelude.map cleanQueryToken . Data.Text.splitOn " "
where
cleanQueryToken :: Text -> Text
cleanQueryToken = Data.Text.replace "," "" . Data.Text.toLower . Data.Text.strip
tokenScore :: Text -> Int
tokenScore token
| Data.Text.length token < 1 = 0
| Data.Text.isInfixOf token fontName = isInfixOfFontName token
| otherwise = 0
where
isInfixOfFontName :: Text -> Int
isInfixOfFontName token'
| token' `elem` ["bold", "medium", "light", "regular", "italic"] = 1
| isNothing (readMaybe (Data.Text.unpack token') :: Maybe Int) = 3
| otherwise = 0
getListOfFontNames :: IO [Text]
getListOfFontNames = do
(_, stdout, _) <- readProcessWithExitCode "convert" ["-list", "font"] []
let fontNames =
Prelude.map (Data.Text.strip . Data.Text.drop 5 . Data.Text.strip) $
Prelude.filter (Data.Text.isInfixOf "font:" . Data.Text.toLower) $
Data.Text.splitOn "\n" $
Data.Text.strip $
Data.Text.pack stdout
return fontNames
maybeGetFirstFrameFilePath :: String -> IO (Maybe FilePath)
maybeGetFirstFrameFilePath tempDir =
try (makeAbsolute tempDir) >>= tryListDir >>= maybeFirstFilePath
where
tryListDir :: Either IOError FilePath -> IO (FilePath, Either IOError [FilePath])
tryListDir (Left y) = return ("", Left y)
tryListDir (Right dir) = try (listDirectory dir) >>= \ e -> return (dir, e)
maybeFirstFilePath :: (FilePath, Either IOError [FilePath]) -> IO (Maybe FilePath)
maybeFirstFilePath (_, Left _) = return Nothing
maybeFirstFilePath (_, Right []) = return Nothing
maybeFirstFilePath (dir, Right (x:_)) = return (Just (normalise $ joinPath [dir, x]))
maybeGetFirstFrameWidthHeight :: Maybe FilePath -> IO (Maybe (Int, Int))
maybeGetFirstFrameWidthHeight Nothing = return Nothing
maybeGetFirstFrameWidthHeight (Just dir) =
readProcessWithExitCode "identify" [dir] [] >>=
\ (_, stdout, _) ->
maybeConvertWidthHeightString $
findWidthHeightString $
splitOn " " $
Data.Text.pack stdout
where
findWidthHeightString :: [Text] -> Text
findWidthHeightString (_:_:c:_:_:_:_:_:_:_) = c
findWidthHeightString _ = ""
maybeConvertWidthHeightString :: Text -> IO (Maybe (Int, Int))
maybeConvertWidthHeightString "" = return Nothing
maybeConvertWidthHeightString s =
if Prelude.length splitOnX == 2
then return (Just (pluckWidth splitOnX, pluckHeight splitOnX))
else return Nothing
where
splitOnX :: [Text]
splitOnX = splitOn "x" $ Data.Text.toLower s
pluckWidth :: [Text] -> Int
pluckWidth (x:_:_) = read (Data.Text.unpack x) :: Int
pluckWidth _ = 0
pluckHeight :: [Text] -> Int
pluckHeight (_:y:_) = read (Data.Text.unpack y) :: Int
pluckHeight _ = 0
fontChoiceOrDefault :: GifParams -> String
fontChoiceOrDefault GifParams { fontChoice = fontName } =
if Data.List.null cleanedFontName
then defaultFontChoice
else cleanedFontName
where
cleanedFontName :: String
cleanedFontName = (Data.Text.unpack . Data.Text.strip . Data.Text.pack) fontName