Tissevert
/
hablo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Make cardImage optional and detect it just like favicons

This commit is contained in:
Tissevert 2019-02-19 18:40:32 +01:00
parent bcdcfb4ff7
commit 602e345977
2 changed files with 15 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
src/Blog/Skin.hs
View File

@ -14,30 +14,31 @@ import System.FilePath ((</>), (<.>))
data Skin = Skin { data Skin = Skin {
banner :: Maybe String banner :: Maybe String
, cardImage :: FilePath , cardImage :: Maybe FilePath
, favicon :: Maybe FilePath , favicon :: Maybe FilePath
, head :: Maybe String , head :: Maybe String
, previewArticlesCount :: Int , previewArticlesCount :: Int
, previewLinesCount :: Int , previewLinesCount :: Int
} }
findFavicon :: Arguments -> IO (Maybe FilePath) absolute :: FilePath -> FilePath
findFavicon arguments = absolute ('.':path) = path
case Arguments.favicon arguments of absolute path = "/" </> path
Just path -> return . Just $ absolute path
_ -> fmap absolute . listToMaybe <$> filterM doesFileExist pathsToCheck findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
findImage _ (Just path) = return . Just $ absolute path
findImage name Nothing =
fmap absolute . listToMaybe <$> filterM doesFileExist pathsToCheck
where where
directories = [".", "image", "images", "pictures", "skin", "static"] directories = [".", "image", "images", "pictures", "skin", "static"]
extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"] extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]
pathsToCheck = [ dir </> "favicon" <.> ext | dir <- directories, ext <- extensions ] pathsToCheck = [ dir </> name <.> ext | dir <- directories, ext <- extensions ]
absolute ('.':path) = path
absolute path = "/" </> path
build :: String -> Arguments -> IO Skin build :: String -> Arguments -> IO Skin
build blogName arguments = do build blogName arguments = do
let cardImage = maybe ("/image" </> blogName <.> "png") id $ Arguments.cardImage arguments
banner <- mapM readFile $ Arguments.bannerPath arguments banner <- mapM readFile $ Arguments.bannerPath arguments
favicon <- findFavicon arguments cardImage <- findImage blogName $ Arguments.cardImage arguments
favicon <- findImage "favicon" $ Arguments.favicon arguments
head <- mapM readFile $ Arguments.headPath arguments head <- mapM readFile $ Arguments.headPath arguments
return $ Skin { return $ Skin {
banner banner

4
src/Dom.hs
View File

@ -9,6 +9,7 @@ import qualified Article (preview)
import ArticlesList (ArticlesList(..), otherUrl, pageTitle) import ArticlesList (ArticlesList(..), otherUrl, pageTitle)
import Blog (Blog(..), Path(..), Skin(..), Wording(..)) import Blog (Blog(..), Path(..), Skin(..), Wording(..))
import qualified Blog (get) import qualified Blog (get)
import Control.Applicative ((<|>))
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import qualified Data.Map as Map (keys, lookup) import qualified Data.Map as Map (keys, lookup)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
@ -68,10 +69,11 @@ makeCard :: String -> Text -> Maybe String -> HtmlGenerator ()
makeCard title description image = do makeCard title description image = do
og "title" $ pack title og "title" $ pack title
og "description" description og "description" description
og "image" =<< pack <$> maybe (Blog.get $skin.$cardImage) return image maybeImage =<< ((image <|>) <$> (Blog.get $skin.$cardImage))
og "site_name" =<< (Blog.get $name.$pack) og "site_name" =<< (Blog.get $name.$pack)
where where
og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value] og attribute value = meta_ [makeAttribute "property" $ "og:" <> attribute , content_ value]
maybeImage = maybe (return ()) (og "image" . pack)
navigationA :: Term arg result => arg -> result navigationA :: Term arg result => arg -> result
navigationA = "a" `termWith` [class_ "navigation"] navigationA = "a" `termWith` [class_ "navigation"]